From 8198559a94022da11fa68f2daf11de397b56a4d5 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 20 Feb 2025 16:14:52 +0100 Subject: [PATCH 001/187] build(Makefile): fill uniworxdb before starting backend --- Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile b/Makefile index 89fb315b7..fb2d5a1b8 100644 --- a/Makefile +++ b/Makefile @@ -99,6 +99,7 @@ start: $(MAKE) start-memcached $(MAKE) start-minio $(MAKE) compile-frontend + $(MAKE) compile-uniworxdb $(MAKE) start-backend .PHONY: %-backend From 0ecb342e8ffbfe54b83f0484aeceed3302b9ff79 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 20 Feb 2025 17:33:31 +0100 Subject: [PATCH 002/187] build(Makefile): add clean-images target --- Makefile | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index fb2d5a1b8..fddf45370 100644 --- a/Makefile +++ b/Makefile @@ -69,13 +69,15 @@ clean: -rm -rf .stack-work .stack-work.lock -rm -rf bin .Dockerfile develop -$(CONTAINER_COMMAND) container prune --force -.PHONY: clean-all -# HELP: like clean but with full container, image, and volume prune -clean-all: clean - -rm -rf .stack +.PHONY: clean-images +clean-images: clean -$(CONTAINER_COMMAND) system prune --all --force --volumes -$(CONTAINER_COMMAND) image prune --all --force -$(CONTAINER_COMMAND) volume prune --force +.PHONY: clean-all +# HELP: like clean but with full container, image, and volume prune +clean-all: clean-images + -rm -rf .stack .PHONY: release # HELP: create, commit and push a new release From 61fb8b7ea91ce38e81c93a9f28171e10f4a0cade Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 20 Feb 2025 17:34:50 +0100 Subject: [PATCH 003/187] build(Makefile): add help text for clean-images --- Makefile | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index fddf45370..ce876dd5c 100644 --- a/Makefile +++ b/Makefile @@ -70,7 +70,10 @@ clean: -rm -rf bin .Dockerfile develop -$(CONTAINER_COMMAND) container prune --force .PHONY: clean-images -clean-images: clean +# HELP: stop all running containers and clean all images from local repositories +clean-images: + rm -rf develop + sleep 5 -$(CONTAINER_COMMAND) system prune --all --force --volumes -$(CONTAINER_COMMAND) image prune --all --force -$(CONTAINER_COMMAND) volume prune --force From 3151be6f41e62a8132cbc4dad6a3dd5741e9347d Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 21 Feb 2025 12:49:35 +0100 Subject: [PATCH 004/187] build(Makefile): add documentation --- Makefile | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Makefile b/Makefile index ce876dd5c..5adf403ea 100644 --- a/Makefile +++ b/Makefile @@ -94,11 +94,13 @@ release: git push origin $${VERSION} .PHONY: compile +# HELP: perform full compilation (frontend and backend) compile: $(MAKE) compile-frontend $(MAKE) compile-backend .PHONY: start +# HELP: start complete development environment with a fresh test database start: $(MAKE) start-postgres $(MAKE) start-memcached From c8599744952f83b3cd368122efe95ce048a49d54 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 24 Oct 2023 20:32:01 +0000 Subject: [PATCH 005/187] chore(gitignore): do not publish font files (for now) --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index fdaf213a9..96cae5157 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,7 @@ node_modules/ assets/icons assets/favicons bin/ +assets/fonts/ *.hi *.o *.sqlite3 From ee02a50bddfb082ac4e0816f479ac1e2518e9a76 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 24 Oct 2023 20:34:45 +0000 Subject: [PATCH 006/187] chore(node-deps): add ttf2woff as dev dep --- package-lock.json | 37 +++++++++++++++++++++++++++++++------ 1 file changed, 31 insertions(+), 6 deletions(-) diff --git a/package-lock.json b/package-lock.json index 90fa3f82d..83226beae 100644 --- a/package-lock.json +++ b/package-lock.json @@ -13748,6 +13748,12 @@ "version": "2.2.0", "resolved": "https://registry.npmjs.org/p-try/-/p-try-2.2.0.tgz", "integrity": "sha512-R4nPAVTAU0B9D35/Gk3uJf/7XYbQcyohSKdvAxIRSNghFl4e71hVoGnBNQz9cWaXxO2I10KTC+3jMdvvoKw6dQ==", + "dev": true + }, + "param-case": { + "version": "3.0.4", + "resolved": "https://registry.npmjs.org/param-case/-/param-case-3.0.4.tgz", + "integrity": "sha512-RXlj7zCYokReqWpOPH9oYivUzLYZ5vAPIfEmCTNViosC78F8F0H9y7T7gG2M39ymgutxF5gcFEsyZQSph9Bp3A==", "dev": true, "license": "MIT", "engines": { @@ -17956,13 +17962,32 @@ "resolved": "https://registry.npmjs.org/tslib/-/tslib-2.8.0.tgz", "integrity": "sha512-jWVzBLplnCmoaTr13V9dYbiQ99wvZRd0vNWaDRg+aVYRcjDF3nDksxFDE/+fkXnKhpnUUkmx5pK/v8mCtLVqZA==", "dev": true, - "license": "0BSD", - "peer": true + "requires": { + "@cspotcode/source-map-support": "^0.8.0", + "@tsconfig/node10": "^1.0.7", + "@tsconfig/node12": "^1.0.7", + "@tsconfig/node14": "^1.0.0", + "@tsconfig/node16": "^1.0.2", + "acorn": "^8.4.1", + "acorn-walk": "^8.1.1", + "arg": "^4.1.0", + "create-require": "^1.1.0", + "diff": "^4.0.1", + "make-error": "^1.1.1", + "v8-compile-cache-lib": "^3.0.1", + "yn": "3.1.1" + } }, - "node_modules/tty-browserify": { - "version": "0.0.1", - "resolved": "https://registry.npmjs.org/tty-browserify/-/tty-browserify-0.0.1.tgz", - "integrity": "sha512-C3TaO7K81YvjCgQH9Q1S3R3P3BtN3RIM8n+OvX4il1K1zgE8ZhI0op7kClgkxtutIE8hQrcrHBXvIheqKUUCxw==", + "tslib": { + "version": "2.3.1", + "resolved": "https://registry.npmjs.org/tslib/-/tslib-2.3.1.tgz", + "integrity": "sha512-77EbyPPpMz+FRFRuAFlWMtmgUWGe9UOG2Z25NqCwiIjRhOf5iKGuzSe5P2w1laq+FkRy4p+PCuVkJSGkzTEKVw==", + "dev": true + }, + "tunnel-agent": { + "version": "0.6.0", + "resolved": "https://registry.npmjs.org/tunnel-agent/-/tunnel-agent-0.6.0.tgz", + "integrity": "sha1-J6XeoGs2sEoKmWZ3SykIaPD8QP0=", "dev": true, "license": "MIT", "peer": true From 757d383d337e9a6c872dca577710924f5352105c Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 24 Oct 2023 21:37:58 +0000 Subject: [PATCH 007/187] chore(gitlab-ci): install and decode font ttfs --- .gitlab-ci.yml | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index c53b81cf1..433136558 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -54,6 +54,33 @@ stages: - backend - release +node dependencies: + stage: frontend:build + script: + - nix -L build -o result ".#uniworxNodeDependencies" + - nix-store --export $(nix-store -qR result) | xz -T0 -2 > node-dependencies.nar.xz + before_script: &nix-before + - git config --global init.defaultBranch master + - install -v -m 0700 -d ~/.ssh + - install -v -T -m 0644 "${SSH_KNOWN_HOSTS}" ~/.ssh/known_hosts + - install -v -T -m 0400 "${SSH_DEPLOY_KEY}" ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config; + - install -v -T -m 0644 "${FONTAWESOME_NPM_AUTH_FILE}" /etc/fontawesome-token + - install -v -T -m 0644 "${FONTBASE64_STONE_SANS_FRAPORT_II_MD}" /etc/fonts/Stone-Sans-Fraport-II-Md.base64 + - base64 --decode /etc/fonts/Stone-Sans-Fraport-II-Md.base64 > /etc/fonts/Stone-Sans-Fraport-II-Md.ttf + - install -v -T -m 0644 "${FONTBASE64_STONE_SANS_FRAPORT_II_MDIT}" /etc/fonts/Stone-Sans-Fraport-II-MdIt.base64 + - base64 --decode /etc/fonts/Stone-Sans-Fraport-II-MdIt.base64 > /etc/fonts/Stone-Sans-Fraport-II-MdIt.ttf + - install -v -T -m 0644 "${FONTBASE64_STONE_SANS_FRAPORT_II_SMBD}" /etc/fonts/Stone-Sans-Fraport-II-SmBd.base64 + - base64 --decode /etc/fonts/Stone-Sans-Fraport-II-SmBd.base64 > /etc/fonts/Stone-Sans-Fraport-II-SmBd.ttf + - install -v -T -m 0644 "${FONTBASE64_STONE_SANS_FRAPORT_II_SMBDIT}" /etc/fonts/Stone-Sans-Fraport-II-SmBdIt.base64 + - base64 --decode /etc/fonts/Stone-Sans-Fraport-II-SmBdIt.base64 > /etc/fonts/Stone-Sans-Fraport-II-SmBdIt.ttf + - install -v -T -m 0644 "${NIX_NETRC}" /etc/nix/netrc + artifacts: + paths: + - node-dependencies.nar.xz + name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}" + expire_in: "1 day" + retry: 2 + interruptible: true setup:dynamic: stage: setup From 733324a732321699c41b891e89eac4acb6e45893 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 11 Sep 2024 13:11:31 +0200 Subject: [PATCH 008/187] chore(config): add config/develop-settings.yml only active if DEVELOPMENT Ensure that certain settings are NOT seen in production, but automatically active in development without using environment variables. --- config/develop-settings.yml | 21 +++++++++++++++++++++ config/settings.yml | 4 ---- src/Settings.hs | 6 ++++-- 3 files changed, 25 insertions(+), 6 deletions(-) create mode 100644 config/develop-settings.yml diff --git a/config/develop-settings.yml b/config/develop-settings.yml new file mode 100644 index 000000000..054a7dfd4 --- /dev/null +++ b/config/develop-settings.yml @@ -0,0 +1,21 @@ +# SPDX-FileCopyrightText: 2024 Steffen Jost +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +# Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable. +# See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables +# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'") +# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings + + +#DEVELOPMENT ONLY, NOT TO BE USED IN PRODUCTION + +avs-licence-synch: + times: [12] + level: 4 + reason-filter: "(firm|block)" + max-changes: 999 + +# Enqueue at specified hour, a few minutes later +job-lms-qualifications-enqueue-hour: 16 +job-lms-qualifications-dequeue-hour: 4 diff --git a/config/settings.yml b/config/settings.yml index 76c341ed6..472d86578 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -91,10 +91,6 @@ synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600" # alle 6 study-features-recache-relevance-within: 172800 study-features-recache-relevance-interval: 293 -# Enqueue at specified hour, a few minutes later -job-lms-qualifications-enqueue-hour: 16 -job-lms-qualifications-dequeue-hour: 4 - log-settings: detailed: "_env:DETAILED_LOGGING:false" all: "_env:LOG_ALL:false" diff --git a/src/Settings.hs b/src/Settings.hs index d2ab95242..b37e2c1bb 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -896,10 +896,12 @@ widgetFile -- hamletFile' :: FilePath -> Q Exp -- hamletFile' nameBase = hamletFile $ "templates" nameBase - --- | Raw bytes at compile time of @config/settings.yml@ +-- | Raw bytes at compile time of @config/settings.yml@ (and also @config/develop-setting.yml for development builds) configSettingsYmlBS :: ByteString configSettingsYmlBS = $(embedFile configSettingsYml) +#ifdef DEVELOPMENT + <> $(embedFile "config/develop-settings.yml") +#endif -- | @config/settings.yml@, parsed to a @Value@. configSettingsYmlValue :: Value From e9a4c838a88a7f352a9909852879b0149ab751a3 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 11 Sep 2024 17:43:56 +0200 Subject: [PATCH 009/187] refactor(map): clarify some unnecessarily obfuscated code also, using Map.fromList is more efficient if the list happens to be ordered --- src/Handler/Admin.hs | 40 +++++------ src/Handler/Admin/Avs.hs | 52 +++++++------- src/Handler/CommCenter.hs | 17 ++--- src/Handler/Firm.hs | 111 +++++++++++++++-------------- src/Handler/LMS.hs | 68 +++++++++--------- src/Handler/LMS/Learners.hs | 20 +++--- src/Handler/LMS/Report.hs | 13 ++-- src/Handler/LMS/Users.hs | 26 +++---- src/Handler/MailCenter.hs | 22 +++--- src/Handler/PrintCenter.hs | 55 +++++++------- src/Handler/Qualification.hs | 50 ++++++------- src/Handler/Utils/Table/Columns.hs | 6 +- 12 files changed, 220 insertions(+), 260 deletions(-) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 1567da027..d19b90320 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -39,10 +39,6 @@ import Handler.Admin.Crontab as Handler.Admin import Handler.Admin.Avs as Handler.Admin import Handler.Admin.Ldap as Handler.Admin --- avoids repetition of local definitions -single :: (k,a) -> Map k a -single = uncurry Map.singleton - -- Types and Template Haskell data ProblemTableAction = ProblemTableMarkSolved @@ -368,22 +364,22 @@ mkProblemLogTable = do , sortable (Just "solved") (i18nCell MsgAdminProblemSolved) $ \( view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t , sortable (Just "solver") (i18nCell MsgAdminProblemSolver) $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR ] - dbtSorting = mconcat - [ single ("time" , SortColumn $ queryProblem >>> (E.^. ProblemLogTime)) - , single ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo)) - -- , single ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo)))) - , single ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company") - , single ("user" , sortUserNameBareM queryUser) - , single ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved)) - , single ("solver", sortUserNameBareM querySolver) + dbtSorting = Map.fromList + [ ("time" , SortColumn $ queryProblem >>> (E.^. ProblemLogTime)) + , ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo)) + -- , ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo)))) + , ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company") + , ("user" , sortUserNameBareM queryUser) + , ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved)) + , ("solver", sortUserNameBareM querySolver) ] - dbtFilter = mconcat - [ single ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName)) - , single ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName)) - , single ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo))) - , single ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved))) - -- , single ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext! - , single ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen + dbtFilter = Map.fromList + [ ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName)) + , ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName)) + , ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo))) + , ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved))) + -- , ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext! + , ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen ifNothingM criterion True $ \(crit::Text) -> do let problem = dbr ^. resultProblem . _entityVal . _problemLogAdminProblem protxt <- adminProblem2Text problem @@ -398,9 +394,9 @@ mkProblemLogTable = do , prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved) ] acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData) - acts = mconcat - [ singletonMap ProblemTableMarkSolved $ pure ProblemTableMarkSolvedData - , singletonMap ProblemTableMarkUnsolved $ pure ProblemTableMarkUnsolvedData + acts = Map.fromList + [ (ProblemTableMarkSolved , pure ProblemTableMarkSolvedData) + , (ProblemTableMarkUnsolved , pure ProblemTableMarkUnsolvedData) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 038538e2a..2da4b2e76 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -38,10 +38,6 @@ import qualified Database.Esqueleto.Utils as E -- import Database.Esqueleto.Utils.TH --- avoids repetition of local definitions -single :: (k,a) -> Map k a -single = uncurry Map.singleton - exceptionWgt :: SomeException -> Widget exceptionWgt (SomeException e) = [whamlet|

Error:

#{tshow e}|] @@ -692,23 +688,23 @@ mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b , sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus ] - dbtSorting = mconcat - [ single $ sortUserNameLink queryUser - , single ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson)) - , single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand)) - , single $ sortUserCompany queryUser - , single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) - , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) - , single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) - , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) - , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal)) - -- , single ("validity" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) + dbtSorting = Map.fromList + [ sortUserNameLink queryUser + , ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson)) + , ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand)) + , sortUserCompany queryUser + , ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) + , ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) + , ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) + , ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) + , ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal)) + -- , ("validity" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) ] - dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUser - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now)) - , single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now)) + , ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \(usrComp `E.InnerJoin` comp) -> do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) @@ -1025,15 +1021,15 @@ getProblemAvsErrorR = do , sortable (Just "avs-last-error") (i18nCell MsgLastAvsSynchError) $ cellMaybe textCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError) ] - dbtSorting = mconcat - [ single (sortUserNameLink qerryUser) - , single ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson)) - , single ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch)) - , single ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError)) + dbtSorting = Map.fromList + [ (sortUserNameLink qerryUser) + , ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson)) + , ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch)) + , ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError)) ] - dbtFilter = mconcat - [ single $ fltrUserNameEmail qerryUser - , single ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError)) + dbtFilter = Map.fromList + [ fltrUserNameEmail qerryUser + , ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError)) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev diff --git a/src/Handler/CommCenter.hs b/src/Handler/CommCenter.hs index 00c688647..3d9e560e8 100644 --- a/src/Handler/CommCenter.hs +++ b/src/Handler/CommCenter.hs @@ -25,11 +25,6 @@ import qualified Database.Esqueleto.PostgreSQL as E import Database.Esqueleto.Utils.TH --- avoids repetition of local definitions -single :: (k,a) -> Map k a -single = uncurry Map.singleton - - data CCTableAction = CCActDummy -- just a dummy, since we don't now yet which actions we will be needing deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -119,12 +114,12 @@ mkCCTable = do , SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName] ] ] - dbtFilter = mconcat - [ single ("sent" , FilterColumn . E.mkDayFilterTo - $ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used - , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just - $ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]) - , single ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus Just + dbtFilter = Map.fromList + [ ("sent" , FilterColumn . E.mkDayFilterTo + $ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used + , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just + $ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]) + , ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename ,E.str2text' $ queryMail row E.?. SentMailHeaders ]) ] diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index e059888e9..4acf5139e 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -39,10 +39,6 @@ import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH --- avoids repetition of local definitions -single :: (k,a) -> Map k a -single = uncurry Map.singleton - -- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId -- decryptUser = decrypt @@ -482,10 +478,10 @@ mkFirmAllTable isAdmin uid = do -- , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes -- , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' ] - dbtFilter = mconcat - [ single $ fltrCompanyNameNr queryAllCompany - , single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId))) - , single ("is-associate" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + dbtFilter = Map.fromList + [ fltrCompanyNameNr queryAllCompany + , ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId))) + , ("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) @@ -496,7 +492,7 @@ mkFirmAllTable isAdmin uid = do ) ) -- THIS WAS WAY TOO SLOW: - -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow + -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow -- (usr :& usrCmp) <- E.from $ E.table @User -- `E.leftJoin` E.table @UserCompany -- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) @@ -515,7 +511,7 @@ mkFirmAllTable isAdmin uid = do -- ) -- ) -- ) - -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow + -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow -- usr <- E.from $ E.table @User -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) -- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) @@ -536,7 +532,7 @@ mkFirmAllTable isAdmin uid = do -- ) -- ) -- ) - -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow + -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow -- usr <- E.from $ E.table @User -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) -- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) @@ -553,7 +549,7 @@ mkFirmAllTable isAdmin uid = do -- )) -- ) -- ) - -- , single ("is-supervisor", FilterColumn $ \row (getLast -> criterion) -> + -- , ("is-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- case criterion of -- Nothing -> E.true -- (Just (crit::Text)) -> E.exists $ do @@ -573,7 +569,7 @@ mkFirmAllTable isAdmin uid = do -- )) -- ) -- ) - , single ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr -> + , ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr -> case criterion of Nothing -> return True :: DB Bool (Just (crit::Text)) -> do @@ -601,7 +597,7 @@ mkFirmAllTable isAdmin uid = do let cid = dbr ^. resultAllCompanyEntity . _entityKey return $ Set.member cid critFirms ) - -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow + -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow -- (usr :& usrCmp) <- E.from $ E.table @User -- `E.leftJoin` E.table @UserCompany -- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) @@ -616,7 +612,7 @@ mkFirmAllTable isAdmin uid = do -- ) -- ) -- ) - , single ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + , ("is-default-supervisor" , 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) @@ -626,7 +622,7 @@ mkFirmAllTable isAdmin uid = do ) E.&&. usrCmp E.^. UserCompanySupervisor E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId ) - , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> + , ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor -- E.where_ $ E.notExists (do @@ -655,8 +651,8 @@ mkFirmAllTable isAdmin uid = do Just True -> E.exists checkSuper Just False -> E.notExists checkSuper ) - , single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) - , single ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do + , ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) + , ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do (usrCmp :& usrQual :& qual) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @QualificationUser `E.on` (\(usrCmp :& usrQual) -> usrCmp E.^. UserCompanyUser E.==. usrQual E.^. QualificationUserUser) @@ -666,8 +662,7 @@ mkFirmAllTable isAdmin uid = do E.&&. qual E.^. QualificationShorthand E.==. E.val criterion E.&&. validQualification now usrQual ) - , single ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress)) - ) + , ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress))) ] dbtFilterUI mPrev = mconcat [ fltrCompanyNameUI mPrev @@ -863,20 +858,20 @@ mkFirmUserTable isAdmin cid = do in numCell prio <> spacerCell <> ifIconCell isPrime IconTop , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr ] - dbtSorting = mconcat - [ single $ sortUserNameLink queryUserUser - , single $ sortUserEmail queryUserUser - , singletonMap "postal-pref" $ SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal) - , singletonMap "matriculation" $ SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer) - , singletonMap "personal-number" $ SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber) - , singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors - , singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute - , singletonMap "usr-reason" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason) - , singletonMap "priority" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority) + dbtSorting = Map.fromList + [ sortUserNameLink queryUserUser + , sortUserEmail queryUserUser + , ("postal-pref" , SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal) ) + , ("matriculation" , SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer) ) + , ("personal-number" , SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber)) + , ("supervisors" , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors ) + , ("reroutes" , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute ) + , ("usr-reason" , SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason) ) + , ("priority" , SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority) ) ] - dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUserUser - , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUserUser + , ("has-supervisor", FilterColumn $ \row (getLast -> criterion) -> let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId @@ -884,7 +879,8 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + ) + , ("has-company-supervisor", FilterColumn $ \row (getLast -> criterion) -> let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId @@ -897,7 +893,8 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + ) + , ("has-foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId @@ -910,7 +907,8 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) -> + ) + , ("supervisor-is", FilterColumn $ \row (getLast -> criterion) -> case criterion of Just uid -> do -- uid <- decryptUser uuid @@ -919,7 +917,8 @@ mkFirmUserTable isAdmin cid = do E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid _otherwise -> E.true - , singletonMap "supervisors-are" $ FilterColumn $ \row criteria -> + ) + , ("supervisors-are", FilterColumn $ \row criteria -> case criteria of _ | Set.null criteria -> E.true | otherwise -> do @@ -928,7 +927,8 @@ mkFirmUserTable isAdmin cid = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria - , singletonMap "is-primary-company" $ FilterColumn $ \row (getLast -> criterion) -> + ) + , ("is-primary-company", FilterColumn $ \row (getLast -> criterion) -> let checkPrimary = do other <- E.from $ E.table @UserCompany E.where_ $ other E.^. UserCompanyUser E.==. queryUserUserCompany row E.^. UserCompanyUser @@ -937,6 +937,7 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just False -> E.exists checkPrimary Just True -> E.notExists checkPrimary + ) ] -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat @@ -1251,31 +1252,32 @@ mkFirmSuperTable isAdmin cid = do , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True) , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr ] - dbtSorting = mconcat - [ single $ sortUserNameLink querySuperUser - , single $ sortUserEmail querySuperUser - , singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer) - , singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber) - , singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal) - , singletonMap "supervised" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing - , singletonMap "rerouted" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) - , singletonMap "user-company" $ SortColumn (\row -> E.subSelect $ do + dbtSorting = Map.fromList + [ sortUserNameLink querySuperUser + , sortUserEmail querySuperUser + , ("matriculation" , SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer)) + , ("personal-number" , SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber)) + , ("postal-pref" , SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal)) + , ("supervised" , SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing) + , ("rerouted" , SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))) + , ("user-company" , SortColumn (\row -> E.subSelect $ do (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySuperUser row E.^. UserId E.orderBy [E.asc $ cmp E.^. CompanyName] return (cmp E.^. CompanyName) - ) - , singletonMap "def-super" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor) - , singletonMap "def-reroute" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute) + )) + , ("def-super" , SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor)) + , ("def-reroute" , SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute)) ] - dbtFilter = mconcat - [ single $ fltrUserNameEmail querySuperUser - , singletonMap "is-foreign-supervisor" $ FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) -> + dbtFilter = Map.fromList + [ fltrUserNameEmail querySuperUser + , ("is-foreign-supervisor", FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) -> case criterion of Nothing -> E.true Just True -> E.isNothing $ suc E.?. UserCompanyUser Just False -> E.isJust $ suc E.?. UserCompanyUser - , singletonMap "super-relation-foreign" $ FilterColumn $ \row (getLast -> criterion) -> + ) + , ("super-relation-foreign", FilterColumn $ \row (getLast -> criterion) -> let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId @@ -1288,6 +1290,7 @@ mkFirmSuperTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper + ) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index ab0fa1964..13f782661 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -50,10 +50,6 @@ import Handler.LMS.Report as Handler.LMS import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production! --- avoids repetition of local definitions -single :: (k,a) -> Map k a -single = uncurry Map.singleton - -- Button only needed here data ButtonManualLms = BtnLmsEnqueue | BtnLmsDequeue deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic) @@ -457,54 +453,54 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = cols getCompanyName - dbtSorting = mconcat - [ single $ sortUserNameLink queryUser - , single $ sortUserEmail queryUser - , single $ sortUserMatriclenr queryUser - , single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) - -- , single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday) - , single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) - , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) - , single ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) - , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) - , single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) - , single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) - -- , single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay)) - , single ("status" , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay + dbtSorting = Map.fromList + [ sortUserNameLink queryUser + , sortUserEmail queryUser + , sortUserMatriclenr queryUser + , ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) + -- , ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday) + , ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) + , ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) + , ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) + , ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) + , ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) + -- , ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay)) + , ("status" , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay , queryLmsUser row E.^. LmsUserNotified ](queryLmsUser row E.^. LmsUserStarted)) - , single ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) - , single ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) - , single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) - , single ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date - , single ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) - , single ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + , ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) + , ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) + , ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) + , ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date + , ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) + , ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) - ) + ) ] - dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUser - , single ("ident" , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) - , single ("status" , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus)) - -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) - -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , ("ident" , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) + , ("status" , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus)) + -- , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) + , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) + -- , ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> -- if | Just renewal <- mbRenewal -- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal -- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday -- | otherwise -> E.true -- ) - , single ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) - , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> + , ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) + , ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) - , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> + , ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \(usrComp `E.InnerJoin` comp) -> do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) @@ -514,7 +510,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) , fltrAVSCardNos queryUser - , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if + , ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria ) diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 144d8f9bb..239b5d061 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -76,19 +76,15 @@ instance FromNamedRecord LmsUserTableCsv where <*> csv Csv..: csvLmsLock instance CsvColumnsExplained LmsUserTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsPin MsgCsvColumnLmsPin - , single csvLmsResetPin MsgCsvColumnLmsResetPin - , single csvLmsDelete MsgCsvColumnLmsDelete - , single csvLmsStaff MsgCsvColumnLmsStaff - , single csvLmsResetTries MsgCsvColumnLmsResetTries - , single csvLmsLock MsgCsvColumnLmsLock + csvColumnsExplanations _ = Map.fromList + [ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent) + , (csvLmsPin , msg2widget MsgCsvColumnLmsPin) + , (csvLmsResetPin , msg2widget MsgCsvColumnLmsResetPin) + , (csvLmsDelete , msg2widget MsgCsvColumnLmsDelete) + , (csvLmsStaff , msg2widget MsgCsvColumnLmsStaff) + , (csvLmsResetTries , msg2widget MsgCsvColumnLmsResetTries) + , (csvLmsLock , msg2widget MsgCsvColumnLmsLock) ] - where - single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget - single k v = singletonMap k [whamlet|_{v}|] - mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget) diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index c360c3eb9..66d846232 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -64,15 +64,12 @@ instance FromNamedRecord LmsReportTableCsv where <*> csv Csv..: csvLmsLock instance CsvColumnsExplained LmsReportTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsDate MsgCsvColumnLmsDate - , single csvLmsResult MsgCsvColumnLmsResult - , single csvLmsLock MsgCsvColumnLmsLock + csvColumnsExplanations _ = Map.fromList + [ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent) + , (csvLmsDate , msg2widget MsgCsvColumnLmsDate) + , (csvLmsResult , msg2widget MsgCsvColumnLmsResult) + , (csvLmsLock , msg2widget MsgCsvColumnLmsLock) ] - where - single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget - single k v = singletonMap k [whamlet|_{v}|] data LmsReportCsvActionClass = LmsReportInsert | LmsReportUpdate deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index b5f534b5a..e4b2eb990 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -68,23 +68,19 @@ instance FromNamedRecord LmsUserTableCsv where <*> csv Csv..: csvLmsStaff instance CsvColumnsExplained LmsUserTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsPin MsgCsvColumnLmsPin - , single csvLmsResetPin MsgCsvColumnLmsResetPin - , single csvLmsDelete MsgCsvColumnLmsDelete - , single csvLmsStaff MsgCsvColumnLmsStaff + csvColumnsExplanations _ = Map.fromList + [ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent) + , (csvLmsPin , msg2widget MsgCsvColumnLmsPin) + , (csvLmsResetPin , msg2widget MsgCsvColumnLmsResetPin) + , (csvLmsDelete , msg2widget MsgCsvColumnLmsDelete) + , (csvLmsStaff , msg2widget MsgCsvColumnLmsStaff) ] - where - single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget - single k v = singletonMap k [whamlet|_{v}|] - mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkUserTable _sid qsh qid = do cutoff <- liftHandler $ lmsDeletionDate Nothing - dbtCsvName <- csvFilenameLmsUser qsh + dbtCsvName <- csvFilenameLmsUser qsh let dbtCsvSheetName = dbtCsvName let userDBTable = DBTable{..} @@ -160,7 +156,7 @@ getLmsUsersDirectR sid qsh = do selectList [ LmsUserQualification ==. qid , LmsUserEnded ==. Nothing -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta - ] [Asc LmsUserStarted, Asc LmsUserIdent] + ] [Asc LmsUserStarted, Asc LmsUserIdent] {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it Ex.select $ do @@ -175,7 +171,7 @@ getLmsUsersDirectR sid qsh = do , csvLUTstaff = LmsBool False } -} - LmsConf{..} <- getsYesod $ view _appLmsConf + LmsConf{..} <- getsYesod $ view _appLmsConf let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users --csvRenderedHeader = lmsUserTableCsvHeader --cvsRendered = CsvRendered {..} @@ -188,10 +184,10 @@ getLmsUsersDirectR sid qsh = do csvOpts = def { csvFormat = fmtOpts } csvSheetName <- csvFilenameLmsUser qsh let nr = length lms_users - msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" + msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" $logInfoS "LMS" msg addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" - csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered + csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index f84cf4ec7..26ad06075 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -41,12 +41,6 @@ import qualified Data.ByteString.Lazy as LB import Handler.Utils - --- avoids repetition of local definitions -single :: (k,a) -> Map k a -single = uncurry Map.singleton - - data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -101,15 +95,15 @@ mkMCTable = do -- , sortable Nothing (i18nCell MsgCommContent) $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html") -- , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h ] - dbtSorting = mconcat - [ single ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt)) - , single ("recipient" , sortUserNameBareM queryRecipient) + dbtSorting = Map.fromList + [ ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt)) + , ("recipient" , sortUserNameBareM queryRecipient) ] - dbtFilter = mconcat - [ single ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt)) - , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) - , single ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) - -- , single ("regex" , FilterColumn . E.mkRegExFilterWith id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) + dbtFilter = Map.fromList + [ ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt)) + , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) + , ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) + -- , ("regex" , FilterColumn . E.mkRegExFilterWith id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 43af0bff9..1bacb9a47 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -39,11 +39,6 @@ import qualified Data.CaseInsensitive as CI import Jobs.Queue --- avoids repetition of local definitions -single :: (k,a) -> Map k a -single = uncurry Map.singleton - - data LRQF = LRQF { lrqfLetter :: Text , lrqfUser :: Either UserEmail UserId @@ -224,33 +219,33 @@ mkPJTable = do , sortable (Just "qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell , sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap (textCell . getLmsIdent) l ] - dbtSorting = mconcat - [ single ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) - , single ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) - , single ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) - , single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) - , single ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent)) - , single ("recipient" , sortUserNameBareM queryRecipient) - , single ("affected" , sortUserNameBareM queryAffected) - , single ("sender" , sortUserNameBareM querySender ) - , single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName)) - , single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName)) - , single ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser)) + dbtSorting = Map.fromList + [ ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) + , ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) + , ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) + , ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) + , ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent)) + , ("recipient" , sortUserNameBareM queryRecipient) + , ("affected" , sortUserNameBareM queryAffected ) + , ("sender" , sortUserNameBareM querySender ) + , ("course" , SortColumn $ queryCourse >>> (E.?. CourseName)) + , ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName)) + , ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser)) ] - dbtFilter = mconcat - [ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) - , single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) - , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) - , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) - --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) - , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) - , single ("affected" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryAffected) (E.?. UserDisplayName)) - , single ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName)) - , single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName)) - , single ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName)) - , single ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser)) + dbtFilter = Map.fromList + [ ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) + , ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) + , ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) + , ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + --, ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) + , ("affected" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryAffected) (E.?. UserDisplayName)) + , ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName)) + , ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName)) + , ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName)) + , ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser)) - , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) + , ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName & setTooltip MsgTableFilterCommaPlus) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index e2934401d..6eee590d3 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -36,10 +36,6 @@ import Database.Esqueleto.Utils.TH -- import Handler.Utils.Qualification (validQualification) --- avoids repetition of local definitions -single :: (k,a) -> Map k a -single = uncurry Map.singleton - getQualificationSchoolR :: SchoolId -> Handler Html getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) @@ -386,40 +382,40 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = cols getCompanyName - dbtSorting = mconcat - [ single $ sortUserNameLink queryUser - , single $ sortUserEmail queryUser - , single $ sortUserMatriclenr queryUser - , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) - , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) - , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) - , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) - , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) - , single ("lms-status-plus",SortColumnNullsInv $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) + dbtSorting = Map.fromList + [ sortUserNameLink queryUser + , sortUserEmail queryUser + , sortUserMatriclenr queryUser + , ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) + , ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) + , ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) + , ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) + , ("lms-status-plus",SortColumnNullsInv $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) , E.joinV (queryLmsUser row E.?. LmsUserNotified) , queryLmsUser row E.?. LmsUserStarted]) - , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) - , single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + , ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) + , ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) - ) - -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now) + ) + -- , ("validity", SortColumn $ queryQualUser >>> validQualification now) ] - dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUser - , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) , fltrAVSCardNos queryUser - , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if + , ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria ) - , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> + , ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \(usrComp `E.InnerJoin` comp) -> do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) @@ -428,18 +424,18 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) - , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> + , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) + , ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> if | Just renewal <- mbRenewal , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | otherwise -> E.true ) - , single ("tobe-notified", FilterColumn $ \row criterion -> + , ("tobe-notified", FilterColumn $ \row criterion -> if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row) | otherwise -> E.true ) - , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) + , ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index a2feb123e..a8c342a1c 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -8,7 +8,7 @@ module Handler.Utils.Table.Columns where import Import hiding (link) -import qualified Data.Map as Map +-- import qualified Data.Map as Map import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E hiding ((->.)) @@ -830,8 +830,8 @@ fltrCompanyNameNrHdrUI msg mPrev = fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k) - => (a -> E.SqlExpr (Entity User)) -> Map k (FilterColumn t fs) -fltrAVSCardNos queryUser = Map.singleton "avs-card" fch + => (a -> E.SqlExpr (Entity User)) -> (k, FilterColumn t fs) +fltrAVSCardNos queryUser = ("avs-card", fch) where fch = FilterColumnHandler $ \case [] -> return (const E.true) From 0264c87510522db723bf9e0557ec343bc07d644d Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 11 Sep 2024 17:44:09 +0200 Subject: [PATCH 010/187] chore(daily): create stub in preparation for #90 --- .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 4 +-- src/Application.hs | 1 + src/Foundation/Navigation.hs | 8 +++-- src/Handler/School/DayTasks.hs | 36 +++++++++++++++++++ 6 files changed, 47 insertions(+), 4 deletions(-) create mode 100644 src/Handler/School/DayTasks.hs diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 535db4979..2f6e7f48e 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -97,6 +97,7 @@ MenuExamOfficeUsers: Benutzer:innen MenuLecturerInvite: Funktionäre hinzufügen MenuSchoolList: Bereiche MenuSchoolNew: Neuen Bereich anlegen +MenuSchoolDay d@Text: #{d} Tagesansicht MenuExternalExamGrades: Prüfungsleistungen MenuExternalExamUsers: Teilnehmer:innen MenuExternalExamEdit: Bearbeiten diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index d316e7812..c7e4eb0f8 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -97,6 +97,7 @@ MenuExamOfficeUsers: Users MenuLecturerInvite: Add functionaries MenuSchoolList: Departments MenuSchoolNew: Create new department +MenuSchoolDay d@Text: #{d} Day MenuExternalExamGrades: Exam results MenuExternalExamUsers: Participants MenuExternalExamEdit: Edit diff --git a/routes b/routes index 7420b21d1..c6aa0743e 100644 --- a/routes +++ b/routes @@ -157,8 +157,8 @@ /school SchoolListR GET !/school/new SchoolNewR GET POST /school/#SchoolId SchoolR: - / SchoolEditR GET POST - + /edit SchoolEditR GET POST + /day/#Day SchoolDayR GET POST /participants ParticipantsListR GET !evaluation /participants/#TermId/#SchoolId ParticipantsR GET !evaluation diff --git a/src/Application.hs b/src/Application.hs index 12e0cf9c3..ac5854c02 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -137,6 +137,7 @@ import Handler.Users.Add import Handler.Admin import Handler.Term import Handler.School +import Handler.School.DayTasks import Handler.Course import Handler.Sheet import Handler.Submission diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 52e0566f0..5fe8c6c3d 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -144,11 +144,15 @@ breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck $ Just PrintCenter breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR -breadcrumb (SchoolR ssh sRoute) = case sRoute of - SchoolEditR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do +breadcrumb (SchoolR ssh SchoolEditR) = + useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do School{..} <- MaybeT $ get ssh isAdmin <- lift $ hasReadAccessTo SchoolListR return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin) +breadcrumb (SchoolR _ssh (SchoolDayR d)) = do + dt <- formatTime SelFormatDate d + mr <- getMessageRender + return (mr $ MsgMenuSchoolDay dt, Just SchoolListR) breadcrumb SchoolNewR = i18nCrumb MsgMenuSchoolNew $ Just SchoolListR breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgMenuExamOfficeExams Nothing diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs new file mode 100644 index 000000000..15fd0003f --- /dev/null +++ b/src/Handler/School/DayTasks.hs @@ -0,0 +1,36 @@ + +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.School.DayTasks + ( getSchoolDayR, postSchoolDayR + ) where + +import Import + +-- import Handler.Utils + +-- import qualified Data.Set as Set +-- import qualified Data.Map as Map +-- import qualified Data.Aeson as Aeson +-- import qualified Data.Text as Text + +-- import Database.Persist.Sql (updateWhereCount) +-- import Database.Esqueleto.Experimental ((:&)(..)) +-- -- import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy +-- import qualified Database.Esqueleto.Experimental as E +-- import qualified Database.Esqueleto.Utils as E +-- import Database.Esqueleto.Utils.TH + + + + +getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html +getSchoolDayR = postSchoolDayR +postSchoolDayR _ssh _day = do + siteLayout "TODO" $ do + setTitle "Day Tasks" + [whamlet|TODO|] From 5a03d1cabebd77bd203149ebca8649df7118b07e Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 12 Sep 2024 17:46:38 +0200 Subject: [PATCH 011/187] chore(daily): improve stub #90 change DB to JSONB (WIP) --- .../categories/school/de-de-formal.msg | 4 +- messages/uniworx/categories/school/en-eu.msg | 4 +- .../utils/navigation/menu/de-de-formal.msg | 2 +- .../uniworx/utils/navigation/menu/en-eu.msg | 2 +- routes | 2 +- src/Foundation/Navigation.hs | 46 ++++-- src/Handler/School/DayTasks.hs | 139 ++++++++++++++++-- test/Database/Fill.hs | 10 ++ 8 files changed, 177 insertions(+), 32 deletions(-) diff --git a/messages/uniworx/categories/school/de-de-formal.msg b/messages/uniworx/categories/school/de-de-formal.msg index eedea789f..9d678454f 100644 --- a/messages/uniworx/categories/school/de-de-formal.msg +++ b/messages/uniworx/categories/school/de-de-formal.msg @@ -40,4 +40,6 @@ SchoolAuthorshipStatementSheetDefinitionTip: Bitte in sowohl deutscher als auch SchoolAuthorshipStatementSheetExamDefinition: Eigenständigkeitserklärung für prüfungszugehörige Übungsblattabgaben SchoolAuthorshipStatementSheetExamDefinitionTip: Bitte in sowohl deutscher als auch englischer Sprache angeben. SchoolAuthorshipStatementSheetAllowOther: Abweichende Eigenständigkeitserklärungen für nicht-prüfungszugehörige Übungsblätter erlauben? -SchoolAuthorshipStatementSheetExamAllowOther: Abweichende Eigenständigkeitserklärungen für prüfungszugehörige Übungsblätter erlauben? \ No newline at end of file +SchoolAuthorshipStatementSheetExamAllowOther: Abweichende Eigenständigkeitserklärungen für prüfungszugehörige Übungsblätter erlauben? + +DailyActDummy: Platzhalter ohne Funktion \ No newline at end of file diff --git a/messages/uniworx/categories/school/en-eu.msg b/messages/uniworx/categories/school/en-eu.msg index 32109bfa4..5f2a79667 100644 --- a/messages/uniworx/categories/school/en-eu.msg +++ b/messages/uniworx/categories/school/en-eu.msg @@ -40,4 +40,6 @@ SchoolAuthorshipStatementSheetDefinitionTip: Please enter both german and englis SchoolAuthorshipStatementSheetExamDefinition: Statement of Authorship for exam-related exercise sheets SchoolAuthorshipStatementSheetExamDefinitionTip: Please enter both german and english statements. SchoolAuthorshipStatementSheetAllowOther: Allow adaptations for exam-unrelated exercise sheets? -SchoolAuthorshipStatementSheetExamAllowOther: Allow adaptations for exam-related exercise sheets? \ No newline at end of file +SchoolAuthorshipStatementSheetExamAllowOther: Allow adaptations for exam-related exercise sheets? + +DailyActDummy: Placholder without function \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 2f6e7f48e..ae3990d41 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -97,7 +97,7 @@ MenuExamOfficeUsers: Benutzer:innen MenuLecturerInvite: Funktionäre hinzufügen MenuSchoolList: Bereiche MenuSchoolNew: Neuen Bereich anlegen -MenuSchoolDay d@Text: #{d} Tagesansicht +MenuSchoolDay ssh@SchoolId d@Text: #{unSchoolKey ssh} #{d} Tagesansicht MenuExternalExamGrades: Prüfungsleistungen MenuExternalExamUsers: Teilnehmer:innen MenuExternalExamEdit: Bearbeiten diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index c7e4eb0f8..c8775ef4e 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -97,7 +97,7 @@ MenuExamOfficeUsers: Users MenuLecturerInvite: Add functionaries MenuSchoolList: Departments MenuSchoolNew: Create new department -MenuSchoolDay d@Text: #{d} Day +MenuSchoolDay ssh d: #{unSchoolKey ssh} #{d} Day MenuExternalExamGrades: Exam results MenuExternalExamUsers: Participants MenuExternalExamEdit: Edit diff --git a/routes b/routes index c6aa0743e..64b459813 100644 --- a/routes +++ b/routes @@ -154,7 +154,7 @@ !/term/#TermId/#SchoolId TermSchoolCourseListR GET !free -/school SchoolListR GET +/school SchoolListR GET !free !/school/new SchoolNewR GET POST /school/#SchoolId SchoolR: /edit SchoolEditR GET POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 5fe8c6c3d..0bf6d5306 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -149,10 +149,10 @@ breadcrumb (SchoolR ssh SchoolEditR) = School{..} <- MaybeT $ get ssh isAdmin <- lift $ hasReadAccessTo SchoolListR return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin) -breadcrumb (SchoolR _ssh (SchoolDayR d)) = do +breadcrumb (SchoolR ssh (SchoolDayR d)) = do dt <- formatTime SelFormatDate d mr <- getMessageRender - return (mr $ MsgMenuSchoolDay dt, Just SchoolListR) + return (mr $ MsgMenuSchoolDay ssh dt, Just SchoolListR) breadcrumb SchoolNewR = i18nCrumb MsgMenuSchoolNew $ Just SchoolListR breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgMenuExamOfficeExams Nothing @@ -941,19 +941,37 @@ pageActions :: ( MonadHandler m , MonadUnliftIO m ) => Route UniWorX -> m [Nav] -pageActions NewsR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuOpenCourses - , navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)]) - , navAccess' = NavAccessTrue - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False +pageActions NewsR = do + now <- liftIO getCurrentTime + let nowaday = utctDay now + nd <- formatTime SelFormatDate now + schools <- useRunDB $ selectList [] [Asc SchoolShorthand] + return $ + ( NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuOpenCourses + , navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)]) + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] } - , navChildren = [] - } - ] + ) : + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSchoolDay ssh nd + , navRoute = SchoolR ssh $ SchoolDayR nowaday + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + | sch <- schools, let ssh = sch ^. _entityKey + ] pageActions (CourseR tid ssh csh CShowR) = do materialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh MaterialListR tutorialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CTutorialListR diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 15fd0003f..2b99929d1 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -11,26 +11,139 @@ module Handler.School.DayTasks import Import --- import Handler.Utils +import Handler.Utils --- import qualified Data.Set as Set --- import qualified Data.Map as Map --- import qualified Data.Aeson as Aeson +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text -- import Database.Persist.Sql (updateWhereCount) --- import Database.Esqueleto.Experimental ((:&)(..)) --- -- import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy --- import qualified Database.Esqueleto.Experimental as E --- import qualified Database.Esqueleto.Utils as E --- import Database.Esqueleto.Utils.TH +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.Utils.TH +import Database.Esqueleto.PostgreSQL.JSON as E +data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe DailyTableAction +instance Finite DailyTableAction +nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''DailyTableAction id + +data DailyTableActionData = DailyActDummyData + deriving (Eq, Ord, Read, Show, Generic) + +-- | partial JSON object to be used for filtering with "@>" +occurrenceDayValue :: Day -> Value +occurrenceDayValue d = Aeson.object + [ "exceptions" Aeson..= + [ Aeson.object + [ "exception" Aeson..= ("occur"::Text) + , "day" Aeson..= d + ] ] ] +-- TODO: ensure that an appropriate GIN index for the jsonb column is set + + + +type DailyTableExpr = + ( E.SqlExpr (Entity Course) + `E.InnerJoin` E.SqlExpr (Entity Tutorial) + ) + +queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) +queryCourse = $(sqlIJproj 2 1) + + +queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) +queryTutorial = $(sqlIJproj 2 2) + + +type DailyTableData = DBRow (Entity Course, Entity Tutorial) + +resultCourse :: Lens' DailyTableData (Entity Course) +resultCourse = _dbrOutput . _1 + +resultTutorial :: Lens' DailyTableData (Entity Tutorial) +resultTutorial = _dbrOutput . _2 + + +mkDailyTable :: SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) +mkDailyTable ssh nd = do + let + dbtSQLQuery :: DailyTableExpr -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial)) + dbtSQLQuery (course `E.InnerJoin` tut) = do + EL.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse + E.where_ $ course E.^. CourseSchool E.==. E.val ssh + E.&&. ((tut E.^. TutorialTime) @>. (E.jsonbVal $ occurrenceDayValue nd) + ) + return (course, tut) + dbtRowKey = queryTutorial >>> (E.^. TutorialId) + dbtProj = dbtProjId + dbtColonnade = mconcat + [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) + sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal . _courseName . _CI -> t) -> textCell t + , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \(view $ resultTutorial . _entityVal . _tutorialName . _CI -> t) -> textCell t + ] + dbtSorting = Map.fromList + [ ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) + , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) + ] + dbtFilter = Map.fromList + [ ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName)) + , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName)) + ] + dbtFilterUI mPrev = mconcat + [ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse) + , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial) + + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} + dbtIdent :: Text + dbtIdent = "daily" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormNoSubmit + , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty) + -- , dbParamsFormSubmit = FormSubmit + -- , dbParamsFormAdditional + -- = let acts :: Map MCTableAction (AForm Handler MCTableActionData) + -- acts = mconcat + -- [ singletonMap MCActDummy $ pure MCActDummyData + -- ] + -- in renderAForm FormStandard + -- $ (, mempty) . First . Just + -- <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialId Bool DailyTableData) + -> FormResult ( DailyTableActionData, Set TutorialId) + postprocess inp = do + (First (Just act), jobMap) <- inp + let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap + return (act, jobSet) + psValidator = def & defaultSorting [SortAscBy "course", SortAscBy "tutorial"] + over _1 postprocess <$> dbTable psValidator DBTable{..} getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html getSchoolDayR = postSchoolDayR -postSchoolDayR _ssh _day = do - siteLayout "TODO" $ do - setTitle "Day Tasks" - [whamlet|TODO|] +postSchoolDayR ssh nd = do + dday <- formatTime SelFormatDate nd + tableDaily <- runDB $ mkDailyTable ssh nd + siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do + setTitleI (MsgMenuSchoolDay ssh dday) + [whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)} + ^{tableDaily} + |] diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 6827257e6..525d6b290 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1087,6 +1087,11 @@ fillDb = do , exceptStart = TimeOfDay 9 0 0 , exceptEnd = TimeOfDay 16 0 0 } + , ExceptOccur + { exceptDay = nowaday + , exceptStart = TimeOfDay 9 10 0 + , exceptEnd = TimeOfDay 16 10 0 + } ] } , tutorialRegGroup = Just "Schulung" @@ -1128,6 +1133,11 @@ fillDb = do , exceptStart = TimeOfDay 10 12 0 , exceptEnd = TimeOfDay 12 13 0 } + , ExceptOccur + { exceptDay = nowaday + , exceptStart = TimeOfDay 17 10 0 + , exceptEnd = TimeOfDay 18 10 0 + } ] } , tutorialRegGroup = Just "schulung" From 11ef856b2bac911ef9f57de118873d5005b232c4 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 13 Sep 2024 13:39:38 +0200 Subject: [PATCH 012/187] refactor(jsonb): change DB using JSONB, to improve stub #90 --- models/courses.model | 14 ++--- models/tutorials.model | 2 +- src/Handler/Admin/Avs.hs | 22 ++++---- src/Handler/Course/Events/Edit.hs | 2 +- src/Handler/Course/Events/Form.hs | 2 +- src/Handler/Course/Events/New.hs | 2 +- src/Handler/Course/ParticipantInvite.hs | 48 ++++++++--------- src/Handler/School/DayTasks.hs | 15 ++++-- src/Handler/Tutorial/Edit.hs | 8 +-- src/Handler/Tutorial/List.hs | 4 +- src/Handler/Tutorial/New.hs | 4 +- src/Handler/Utils/Occurrences.hs | 14 ++--- src/Handler/Utils/Table/Cells.hs | 2 +- src/Handler/Utils/Table/Columns.hs | 6 +-- src/Import/NoModel.hs | 1 + src/Model.hs | 7 ++- src/Model/Types/DateTime.hs | 70 ++++++++++++++++--------- src/Utils.hs | 1 + src/Utils/Print/CourseCertificate.hs | 28 +++++----- test/Database/Fill.hs | 23 ++++++-- 20 files changed, 160 insertions(+), 115 deletions(-) diff --git a/models/courses.model b/models/courses.model index ded2013dd..5f9702b55 100644 --- a/models/courses.model +++ b/models/courses.model @@ -28,13 +28,13 @@ Course -- Information about a single course; contained info is always visible TermSchoolCourseName term school name -- name must be unique within school and semester deriving Generic CourseEvent - type (CI Text) - course CourseId OnDeleteCascade OnUpdateCascade - room RoomReference Maybe - roomHidden Bool default=false - time Occurrences - note StoredMarkup Maybe - lastChanged UTCTime default=now() + type (CI Text) + course CourseId OnDeleteCascade OnUpdateCascade + room RoomReference Maybe + roomHidden Bool default=false + time (JSONB Occurrences) + note StoredMarkup Maybe + lastChanged UTCTime default=now() deriving Generic CourseAppInstructionFile diff --git a/models/tutorials.model b/models/tutorials.model index be27d6a87..e7e21e8b2 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -9,7 +9,7 @@ Tutorial json capacity Int Maybe -- limit for enrolment in this tutorial room RoomReference Maybe roomHidden Bool default=false - time Occurrences + time (JSONB Occurrences) regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup registerFrom UTCTime Maybe registerTo UTCTime Maybe diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 2da4b2e76..853c3450c 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -1000,15 +1000,15 @@ getProblemAvsErrorR = do E.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring - qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs) - qerryUsrAvs = $(E.sqlIJproj 2 1) - qerryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User) - qerryUser = $(E.sqlIJproj 2 2) + querryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs) + querryUsrAvs = $(E.sqlIJproj 2 1) + querryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User) + querryUser = $(E.sqlIJproj 2 2) reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs) reserrUsrAvs = _dbrOutput . _1 -- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User) -- reserrUser = _dbrOutput . _2 - dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId) + dbtRowKey = querryUsrAvs >>> (E.^. UserAvsId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ colUserNameModalHdrAdmin MsgLmsUser AdminUserR @@ -1022,14 +1022,14 @@ getProblemAvsErrorR = do $ cellMaybe textCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError) ] dbtSorting = Map.fromList - [ (sortUserNameLink qerryUser) - , ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson)) - , ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch)) - , ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError)) + [ sortUserNameLink querryUser + , ("avs-nr" , SortColumn $ querryUsrAvs >>> (E.^. UserAvsNoPerson)) + , ("avs-last-synch", SortColumnNullsInv $ querryUsrAvs >>> (E.^. UserAvsLastSynch)) + , ("avs-last-error", SortColumn $ querryUsrAvs >>> (E.^. UserAvsLastSynchError)) ] dbtFilter = Map.fromList - [ fltrUserNameEmail qerryUser - , ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError)) + [ fltrUserNameEmail querryUser + , ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to querryUsrAvs) (E.^. UserAvsLastSynchError)) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev diff --git a/src/Handler/Course/Events/Edit.hs b/src/Handler/Course/Events/Edit.hs index ceef29fe1..b1af6858e 100644 --- a/src/Handler/Course/Events/Edit.hs +++ b/src/Handler/Course/Events/Edit.hs @@ -28,7 +28,7 @@ postCEvEditR tid ssh csh cID = do , courseEventType = cefType , courseEventRoom = cefRoom , courseEventRoomHidden = cefRoomHidden - , courseEventTime = cefTime + , courseEventTime = cefTime & JSONB , courseEventNote = cefNote , courseEventLastChanged = now } diff --git a/src/Handler/Course/Events/Form.hs b/src/Handler/Course/Events/Form.hs index 29a968826..30eb8ec6c 100644 --- a/src/Handler/Course/Events/Form.hs +++ b/src/Handler/Course/Events/Form.hs @@ -54,6 +54,6 @@ courseEventToForm CourseEvent{..} = CourseEventForm { cefType = courseEventType , cefRoom = courseEventRoom , cefRoomHidden = courseEventRoomHidden - , cefTime = courseEventTime + , cefTime = courseEventTime & unJSONB , cefNote = courseEventNote } diff --git a/src/Handler/Course/Events/New.hs b/src/Handler/Course/Events/New.hs index b43656d98..5c09e2931 100644 --- a/src/Handler/Course/Events/New.hs +++ b/src/Handler/Course/Events/New.hs @@ -26,7 +26,7 @@ postCEventsNewR tid ssh csh = do , courseEventType = cefType , courseEventRoom = cefRoom , courseEventRoomHidden = cefRoomHidden - , courseEventTime = cefTime + , courseEventTime = cefTime & JSONB , courseEventNote = cefNote , courseEventLastChanged = now } diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 53eff795d..c000c9c2b 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -49,15 +49,15 @@ tutorialTemplateNames Nothing = ["Vorlage", "Template"] tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]] tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName -tutorialDefaultName Nothing = formatDayForTutName -tutorialDefaultName (Just ttyp) = +tutorialDefaultName Nothing = formatDayForTutName +tutorialDefaultName (Just ttyp) = let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user -- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this -formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow - where +formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow + where d2u '-' = '_' d2u c = c @@ -151,7 +151,7 @@ instance Monoid AddParticipantsResult where getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR = postCAddUserR -postCAddUserR tid ssh csh = do +postCAddUserR tid ssh csh = do today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime handleAddUserR tid ssh csh (Right today) Nothing -- postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users @@ -163,8 +163,8 @@ postTAddUserR tid ssh csh tutn = handleAddUserR tid ssh csh (Left tutn) Nothing handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html -handleAddUserR tid ssh csh tdesc ttyp = do - (cid, tutTypes, tutNameSuggestions) <- runDB $ do +handleAddUserR tid ssh csh tdesc ttyp = do + (cid, tutTypes, tutNameSuggestions) <- runDB $ do let plainTemplates = tutorialTemplateNames Nothing cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh tutTypes <- E.select $ E.distinct $ do @@ -176,9 +176,9 @@ handleAddUserR tid ssh csh tdesc ttyp = do let typeSet = Set.fromList [ maybe t CI.mk $ Text.stripPrefix temp_sep $ CI.original t | temp <- plainTemplates , let temp_sep = CI.original (temp <> tutorialTypeSeparator) - , E.Value t <- tutTypes + , E.Value t <- tutTypes ] - tutNames <- E.select $ do + tutNames <- E.select $ do tutorial <- E.from $ E.table @Tutorial let tuName = tutorial E.^. TutorialName E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid @@ -192,23 +192,23 @@ handleAddUserR tid ssh csh tdesc ttyp = do currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute - (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm + (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm -- $logDebugS "***AbortProblem***" $ tshow registerConfirmResult - prefillUsers <- case registerConfirmResult of + prefillUsers <- case registerConfirmResult of Nothing -> return mempty - (Just BtnCourseRegisterAbort) -> do + (Just BtnCourseRegisterAbort) -> do addMessageI Warning MsgAborted -- prefill confirmed users for convenience. Note that Browser-Back may also return to the filled form, but history.back() does not in Chrome confirmedActs :: [CourseRegisterActionData] <- exceptT (const $ return mempty) return . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction -- ignore any exception, since it is only used to prefill a form field for convenience return $ Just $ Set.fromList $ fmap crActIdent confirmedActs (Just BtnCourseRegisterConfirm) -> do - confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction + confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction -- $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs let users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs - actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member! + actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member! registeredUsers <- registerUsers cid users whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do @@ -218,13 +218,13 @@ handleAddUserR tid ssh csh tdesc ttyp = do redirect $ CTutorialR tid ssh csh tName TUsersR redirect $ CourseR tid ssh csh CUsersR return mempty - + ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . identifyForm FIDCourseRegister . renderWForm FormStandard $ do let tutTypesMsg = [(SomeMessage tt,tt) | tt <- tutTypes] - tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing) + tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing) auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) prefillUsers auReqTutorial <- optionalActionW - ( (,,) + ( (,,) <$> aopt (textField & cfStrip & cfCI & addDatalist tutNameSuggestions) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ maybeLeft tdesc) @@ -349,12 +349,12 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do existingTut <- getBy $ UniqueTutorial cid newTutorialName templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType, Asc TutorialName] case (existingTut, newFirstDay, templateEnt) of - (Just Entity{entityKey=tid},_,_) -> return tid -- no need to update, we ignore the anchor day + (Just Entity{entityKey=tid},_,_) -> return tid -- no need to update, we ignore the anchor day (Nothing, Just moveDay, Just Entity{entityVal=Tutorial{..}}) -> do Course{..} <- get404 cid term <- get404 courseTerm - let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) - newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime + let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term $ unJSONB tutorialTime) + newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) $ unJSONB tutorialTime dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay mvTime = fmap $ addLocalDays dayDiff newType0 = CI.map (snd . Text.breakOnEnd (CI.original tutorialTypeSeparator)) tutorialType @@ -367,13 +367,13 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do , tutorialCourse = cid , tutorialType = newType , tutorialFirstDay = newFirstDay - , tutorialTime = newTime + , tutorialTime = newTime & JSONB , tutorialRegisterFrom = mvTime tutorialRegisterFrom , tutorialRegisterTo = mvTime tutorialRegisterTo , tutorialDeregisterUntil = mvTime tutorialDeregisterUntil , tutorialLastChanged = now , .. - } [] -- update cannot happen due to previous case + } [] -- update cannot happen due to previous case audit $ TransactionTutorialEdit tutId return tutId _ -> do @@ -385,7 +385,7 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do , tutorialCapacity = Nothing , tutorialRoom = Nothing , tutorialRoomHidden = False - , tutorialTime = Occurrences mempty mempty + , tutorialTime = mempty , tutorialRegGroup = Nothing , tutorialRegisterFrom = Nothing , tutorialRegisterTo = Nothing @@ -393,7 +393,7 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do , tutorialLastChanged = now , tutorialTutorControlled = False , tutorialFirstDay = Nothing - } [] -- update cannot happen due to previous cases + } [] -- update cannot happen due to previous cases audit $ TransactionTutorialEdit tutId return tutId diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 2b99929d1..846e1b615 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -4,6 +4,8 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- TODO during development only +{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO during development only module Handler.School.DayTasks ( getSchoolDayR, postSchoolDayR @@ -13,13 +15,13 @@ import Import import Handler.Utils -import qualified Data.Set as Set +-- import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text -- import Database.Persist.Sql (updateWhereCount) -import Database.Esqueleto.Experimental ((:&)(..)) +-- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E @@ -79,8 +81,11 @@ mkDailyTable ssh nd = do dbtSQLQuery (course `E.InnerJoin` tut) = do EL.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse E.where_ $ course E.^. CourseSchool E.==. E.val ssh - E.&&. ((tut E.^. TutorialTime) @>. (E.jsonbVal $ occurrenceDayValue nd) - ) + E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue nd)) + E.&&. E.exists $ do + trm <- E.from $ E.table @Term + E.where_ $ E.between (E.val nd) (trm E.^. TermStart, trm E.^. TermEnd) + E.&&. trm E.^. TermId E.==. course E.^. CourseTerm return (course, tut) dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtProj = dbtProjId @@ -141,7 +146,7 @@ getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html getSchoolDayR = postSchoolDayR postSchoolDayR ssh nd = do dday <- formatTime SelFormatDate nd - tableDaily <- runDB $ mkDailyTable ssh nd + (_,tableDaily) <- runDB $ mkDailyTable ssh nd siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do setTitleI (MsgMenuSchoolDay ssh dday) [whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)} diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs index 65d616e0a..ee65bd4cc 100644 --- a/src/Handler/Tutorial/Edit.hs +++ b/src/Handler/Tutorial/Edit.hs @@ -25,21 +25,21 @@ getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName - getTEditR = postTEditR postTEditR tid ssh csh tutn = do (cid, tutid, template) <- runDB $ do - (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn + (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid return $ tutor E.^. TutorUser tutorInvites <- sourceInvitationsF @Tutor tutid - let + let template = TutorialForm { tfName = tutorialName , tfType = tutorialType , tfCapacity = tutorialCapacity , tfRoom = tutorialRoom , tfRoomHidden = tutorialRoomHidden - , tfTime = tutorialTime + , tfTime = tutorialTime & unJSONB , tfRegGroup = tutorialRegGroup , tfRegisterFrom = tutorialRegisterFrom , tfRegisterTo = tutorialRegisterTo @@ -64,7 +64,7 @@ postTEditR tid ssh csh tutn = do , tutorialCapacity = tfCapacity , tutorialRoom = tfRoom , tutorialRoomHidden = tfRoomHidden - , tutorialTime = tfTime + , tutorialTime = tfTime & JSONB , tutorialRegGroup = tfRegGroup , tutorialRegisterFrom = tfRegisterFrom , tutorialRegisterTo = tfRegisterTo diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index 3f0c6a48d..ce1cb7a89 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -32,7 +32,7 @@ getCTutorialListR tid ssh csh = do resultTutorial = _dbrOutput . _1 resultParticipants = _dbrOutput . _2 resultShowRoom = _dbrOutput . _3 - + dbtSQLQuery tutorial = do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid let participants :: E.SqlExpr (E.Value Int) @@ -64,7 +64,7 @@ getCTutorialListR tid ssh csh = do , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if | res ^. resultShowRoom -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res | otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text) - , sortable Nothing (i18nCell MsgTableTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime + , sortable Nothing (i18nCell MsgTableTutorialTime) $ \(view $ resultTutorial . _entityVal . _tutorialTime -> ttime) -> occurrencesCell ttime , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . CI.original) tutorialRegGroup , sortable (Just "register-from") (i18nCell MsgRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index 4fa98b0d6..50508ae68 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -25,7 +25,7 @@ postCTutorialNewR tid ssh csh = do ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing formResult newTutResult $ \TutorialForm{..} -> do - insertRes <- runDBJobs $ do + insertRes <- runDBJobs $ do now <- liftIO getCurrentTime term <- get404 $ course ^. _courseTerm insertRes <- insertUnique Tutorial @@ -35,7 +35,7 @@ postCTutorialNewR tid ssh csh = do , tutorialCapacity = tfCapacity , tutorialRoom = tfRoom , tutorialRoomHidden = tfRoomHidden - , tutorialTime = tfTime + , tutorialTime = JSONB tfTime , tutorialRegGroup = tfRegGroup , tutorialRegisterFrom = tfRegisterFrom , tutorialRegisterTo = tfRegisterTo diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 984a4b7a2..93642d524 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -18,8 +18,8 @@ import Utils.Occurrences import Handler.Utils.DateTime -occurrencesWidget :: Occurrences -> Widget -occurrencesWidget (normalizeOccurrences -> Occurrences{..}) = do +occurrencesWidget :: JSONB Occurrences -> Widget +occurrencesWidget (normalizeOccurrences . unJSONB -> Occurrences{..}) = do let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case ScheduleWeekly{..} -> do scheduleStart' <- formatTime SelFormatTime scheduleStart @@ -35,10 +35,10 @@ occurrencesWidget (normalizeOccurrences -> Occurrences{..}) = do $(widgetFile "widgets/occurrence/cell/except-no-occur") $(widgetFile "widgets/occurrence/cell") --- | Get bounds for an Occurrences +-- | Get bounds for an Occurrences occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) -occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays) - where +occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays) + where occDays = (scdDays <> plsDays) \\ excDays -- (excDays <> termHolidays term) -- TODO: should holidays be exluded here? Probably not, as they can be added as exceptions already scdDays = Set.foldr getOccDays mempty occurrencesScheduled @@ -58,7 +58,7 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc dayDiff = diffDays dayNew dayOld offDays = Set.fromList $ termHolidays <> weekends - weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] + weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule switchDayOfWeek os | 0 == dayDiff `mod` 7 = os @@ -74,6 +74,6 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc = advanceExceptions (succ offset, acc) ex | otherwise = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc) - where + where ed = dayOfOccurrenceException ex nd = addDays offset ed diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 02ccc8857..dd5474df8 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -509,7 +509,7 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc -occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a +occurrencesCell :: IsDBTable m a => JSONB Occurrences -> DBCell m a occurrencesCell = cell . occurrencesWidget roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index a8c342a1c..89ebeec61 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -195,9 +195,9 @@ colExamLabel resultLabel = Colonnade.singleton (fromSortable header) body sortExamLabel :: OpticSortColumn (Maybe ExamOfficeLabelName) sortExamLabel queryLabel = singletonMap "exam-label" . SortColumn $ view queryLabel ---------------------- --- Exam occurences -- ---------------------- +---------------------- +-- Exam occurrences -- +---------------------- colOccurrenceStart :: OpticColonnade UTCTime colOccurrenceStart resultStart = Colonnade.singleton (fromSortable header) body diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 90edef7a1..ac2fb34f5 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -190,6 +190,7 @@ import Network.Mail.Mime.Instances as Import import Yesod.Core.Instances as Import () import Data.Aeson.Types.Instances as Import () import Database.Esqueleto.Instances as Import () +import Database.Esqueleto.PostgreSQL.JSON as Import (JSONB(..), unJSONB) import Numeric.Natural.Instances as Import () import Text.Blaze.Instances as Import () import Jose.Jwt.Instances as Import () diff --git a/src/Model.hs b/src/Model.hs index cebdd4056..d5100d4a8 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -29,7 +29,6 @@ import Database.Persist.Sql (BackendKey(..)) import qualified Database.Esqueleto.Legacy as E - type SqlBackendKey = BackendKey SqlBackend @@ -56,7 +55,7 @@ deriving newtype instance FromJSONKey ExamOccurrenceId deriving newtype instance ToSample UserId deriving newtype instance ToSample ExternalApiId --- required Show instances for use of getByJust +-- required Show instances for use of getByJust deriving instance Show (Unique ExamPart) deriving instance Show (Unique QualificationUser) deriving instance Show (Unique LmsUser) @@ -146,7 +145,7 @@ instance IsFileReference PersonalisedSheetFile where fileReferenceTitleField = PersonalisedSheetFileTitle fileReferenceContentField = PersonalisedSheetFileContent fileReferenceModifiedField = PersonalisedSheetFileModified - + instance HasFileReference SubmissionFile where data FileReferenceResidual SubmissionFile = SubmissionFileResidual { submissionFileResidualSubmission :: SubmissionId @@ -247,5 +246,5 @@ instance IsFileReference MaterialFile where deriveJSON defaultOptions { tagSingleConstructors = False , fieldLabelModifier = camelToPathPiece' 2 - , omitNothingFields = True + , omitNothingFields = True } ''QualificationUserBlock diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index bc31638b4..b329ad68e 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -39,7 +39,7 @@ import Data.Aeson.Types as Aeson -- Terms and anything loosely related to time newtype TermIdentifier = TermIdentifier { year :: Integer } -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' - deriving (Show, Read, Eq, Ord, Generic, Enum) + deriving (Show, Read, Eq, Ord, Generic, Enum) deriving newtype (Binary) -- , ISO8601, PersistField, PersistFieldSql) -- , ToJSON, FromJSON) deriving anyclass (NFData) -- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Enum, Binary, NFData) @@ -86,23 +86,23 @@ termFromText t = Right TermIdentifier {..} ---- * | Just (review shortened -> year) <- readMaybe $ Text.unpack t ---- * = Right TermIdentifier {..} - | otherwise - = Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number." - - + | otherwise + = Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number." + + daysPerYear :: Rational daysPerYear = 365 + (97 % 400) -dayOffset :: Rational +dayOffset :: Rational dayOffset = fromIntegral yearzero + (fromIntegral diffstart / daysPerYear) - where + where dayzero = toEnum 0 yearzero = fst3 $ toGregorian dayzero - diffstart = diffDays dayzero $ fromGregorian yearzero 1 1 - + diffstart = diffDays dayzero $ fromGregorian yearzero 1 1 + -- Attempt to ensure that ``truncate . termToRational == fst3 . toGregorian . getTermDay´´ holds -termToRational :: TermIdentifier -> Rational -termToRational = fromInteger . year +termToRational :: TermIdentifier -> Rational +termToRational = fromInteger . year termFromRational :: Rational -> TermIdentifier termFromRational = TermIdentifier . floor @@ -159,7 +159,7 @@ guessDay t TermDayEnd = pred $ guessDay (succ t) TermDayStart guessDay t TermDayLectureEnd = pred $ pred $ guessDay t TermDayEnd -- Friday of last calendar week, no lectures on Saturday/Sunday -withinTerm :: Day -> TermIdentifier -> Bool +withinTerm :: Day -> TermIdentifier -> Bool withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd data OccurrenceSchedule = ScheduleWeekly @@ -189,15 +189,15 @@ data OccurrenceException = ExceptOccur deriving anyclass (NFData) -- Handler.Utils.Occurrences.occurrencesAddBusinessDays assumes that OccurrenceException is ordered chronologically -instance Ord OccurrenceException where - compare ExceptOccur{exceptDay=ad, exceptStart=as, exceptEnd=ae} ExceptOccur{exceptDay=bd, exceptStart=bs, exceptEnd=be} +instance Ord OccurrenceException where + compare ExceptOccur{exceptDay=ad, exceptStart=as, exceptEnd=ae} ExceptOccur{exceptDay=bd, exceptStart=bs, exceptEnd=be} = compare (ad,as,ae) (bd,bs,be) compare ExceptOccur{exceptDay=d, exceptStart=s} ExceptNoOccur{exceptTime=e} = replaceEq LT $ compare (LocalTime d s) e - compare ExceptNoOccur{exceptTime=e } ExceptOccur{exceptDay=d, exceptStart=s} + compare ExceptNoOccur{exceptTime=e } ExceptOccur{exceptDay=d, exceptStart=s} = replaceEq GT $ compare e (LocalTime d s) compare ExceptNoOccur{exceptTime=ae } ExceptNoOccur{exceptTime=be } - = compare ae be + = compare ae be deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 @@ -225,24 +225,46 @@ deriveJSON defaultOptions } ''Occurrences derivePersistFieldJSON ''Occurrences +instance Semigroup Occurrences where + (<>) Occurrences{occurrencesScheduled = aSched , occurrencesExceptions = aExcept} + Occurrences{occurrencesScheduled = bSched, occurrencesExceptions = bExcept} + = Occurrences{occurrencesScheduled = aSched <> bSched, occurrencesExceptions = aExcept <> bExcept} + +instance Monoid Occurrences where + mempty = Occurrences mempty mempty + +-- TODO: move elsewhere +deriving newtype instance NFData a => NFData (JSONB a) +deriving newtype instance Semigroup a => Semigroup (JSONB a) +deriving newtype instance Monoid a => Monoid (JSONB a) + +jsonbOCCUR :: Maybe (JSONB Occurrences) -> Occurrences +jsonbOCCUR = foldMap unJSONB + +occurJSONB :: Occurrences -> Maybe (JSONB Occurrences) +occurJSONB = Just . JSONB + +_Occurrences :: Iso' (JSONB Occurrences) Occurrences +_Occurrences = iso unJSONB JSONB + + nullaryPathPiece ''DayOfWeek camelToPathPiece - -- test :: IO [OccurrenceException] --- test = do +-- test = do -- now <- getCurrentTime -- tz <- getCurrentTimeZone --- let lt1 = utcToLocalTime tz now --- tomorrow = addUTCTime nominalDay now +-- let lt1 = utcToLocalTime tz now +-- tomorrow = addUTCTime nominalDay now -- lt2 = utcToLocalTime tz tomorrow --- yesterday = addUTCTime (negate nominalDay) now +-- yesterday = addUTCTime (negate nominalDay) now -- lt3 = utcToLocalTime tz yesterday --- pure +-- pure -- [ ExceptOccur (utctDay tomorrow ) midday midnight -- , ExceptOccur (utctDay now ) midnight midnight -- , ExceptOccur (utctDay now ) midday midnight --- , ExceptOccur (utctDay yesterday) midday midnight +-- , ExceptOccur (utctDay yesterday) midday midnight -- , ExceptNoOccur lt3 -- , ExceptNoOccur lt1 -- , ExceptNoOccur lt2 diff --git a/src/Utils.hs b/src/Utils.hs index a584ec402..617293cae 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -946,6 +946,7 @@ deepAlt altFst Nothing = altFst deepAlt (Just Nothing) altSnd = altSnd deepAlt altFst _ = altFst +-- | flipped `foldMap` with type restriction to Maybe, also see @maybeMonoid@ maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty = flip foldMap diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs index 039885b7e..3a61e258a 100644 --- a/src/Utils/Print/CourseCertificate.hs +++ b/src/Utils/Print/CourseCertificate.hs @@ -6,7 +6,7 @@ module Utils.Print.CourseCertificate where -import Import +import Import -- import Data.Char as Char import qualified Data.Text as Text @@ -21,10 +21,10 @@ import Handler.Utils.Occurrences data LetterCourseCertificate = LetterCourseCertificate { ccCourseId :: CourseId - , ccCourseName :: Text - , ccCourseShorthand :: Text + , ccCourseName :: Text + , ccCourseShorthand :: Text , ccCourseSchool :: Text - , ccTutorialName :: Text + , ccTutorialName :: Text , ccCourseContent :: Maybe [Text] , ccCourseBegin :: Maybe Day , ccCourseEnd :: Maybe Day @@ -38,7 +38,7 @@ data LetterCourseCertificate = LetterCourseCertificate deriving (Eq, Show) -instance MDLetter LetterCourseCertificate where +instance MDLetter LetterCourseCertificate where encryptPDFfor _ = NoPassword getLetterKind _ = Plain getLetterEnvelope _ = 'c' @@ -48,21 +48,21 @@ instance MDLetter LetterCourseCertificate where getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md") getMailSubject l = SomeMessage . MsgCourseCertificate $ ccCourseName l - letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt = + letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt = mkMeta [ toMeta "participant" ccParticipant , toMeta "subject-meta" ccParticipant , mbMeta "fra-number" ccFraNumber - , mbMeta "fra-department" ccFraDepartment + , mbMeta "fra-department" ccFraDepartment , mbMeta "company" ccCompany , toMeta "course-name" ccCourseName , mbMeta "course-content" ccCourseContent , mbMeta "course-begin" (format SelFormatDate <$> ccCourseBegin) , mbMeta "course-end" (format SelFormatDate <$> ccCourseEnd) , toMeta "lang" (fromMaybe lang ccCourseLang) - ] + ] - getPJId LetterCourseCertificate{..} = + getPJId LetterCourseCertificate{..} = PrintJobIdentification { pjiName = "Certificate" , pjiApcAcknowledge = "cc-" <> ccCourseName @@ -79,7 +79,7 @@ instance MDLetter LetterCourseCertificate where makeCourseCertificates :: Traversable t => Tutorial -> Maybe Lang -> t UserId -> DB (t LetterCourseCertificate) makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName , tutorialCourse = ccCourseId - , tutorialTime = occurrences + , tutorialTime = unJSONB -> occurrences } ccCourseLang participants = do Course{ courseName = CI.original -> ccCourseName , courseShorthand = CI.original -> ccCourseShorthand @@ -91,13 +91,13 @@ makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName let (ccCourseBegin, ccCourseEnd) = eq2nothing $ occurrencesBounds term occurrences forM participants $ \ccParticipantId -> do User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 ccParticipantId - (ccFraNumber, ccFraDepartment, ccCompany) <- + (ccFraNumber, ccFraDepartment, ccCompany) <- if isJust userCompanyDepartment && validFraportPersonalNumber userCompanyPersonalNumber - then + then return (userCompanyPersonalNumber, userCompanyDepartment, Nothing) - else do + else do usrComp <- selectFirst [UserCompanyUser ==. ccParticipantId] [Desc UserCompanyId] comp <- forM usrComp (get . userCompanyCompany . entityVal) let res = (comp ^? _Just . _Just . _companyName . _CI) <|> userCompanyDepartment -- if there is no company, use the department as fallback, if possible - return (Nothing, Nothing, res) + return (Nothing, Nothing, res) return LetterCourseCertificate{..} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 525d6b290..f1047d2ef 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -63,9 +63,10 @@ fillDb = do insert' = fmap (either entityKey id) . insertBy addBDays = addBusinessDays Fraport -- holiday area to use - n_day n = addBDays n $ utctDay now + nowaday = utctDay now + n_day n = addBDays n nowaday n_day' n = now { utctDay = n_day n } - (currentYear, _currentMonth, _currentDay) = toGregorian $ utctDay now + (currentYear, _currentMonth, _currentDay) = toGregorian nowaday currentTerm = TermIdentifier currentYear nextTerm n = toEnum . (+n) $ fromEnum currentTerm @@ -1075,7 +1076,23 @@ fillDb = do _ -> "B777" , tutorialRoomHidden = False , tutorialTime = Occurrences - { occurrencesScheduled = Set.empty + { occurrencesScheduled = Set.fromList + [ ScheduleWeekly + { scheduleDayOfWeek = Thursday + , scheduleStart = TimeOfDay 11 11 0 + , scheduleEnd = TimeOfDay 12 22 0 + } + , ScheduleWeekly + { scheduleDayOfWeek = Friday + , scheduleStart = TimeOfDay 13 33 0 + , scheduleEnd = TimeOfDay 14 44 0 + } + , ScheduleWeekly + { scheduleDayOfWeek = Sunday + , scheduleStart = TimeOfDay 15 55 0 + , scheduleEnd = TimeOfDay 16 06 0 + } + ] , occurrencesExceptions = Set.fromList [ ExceptOccur { exceptDay = nTimes 7 succ firstDay From 4dbe005709743c683cf78cc629b651f1c2552812 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 13 Sep 2024 16:18:38 +0200 Subject: [PATCH 013/187] chore(daily): add page actions #90 --- .../utils/handler_form/occurrences/de-de-formal.msg | 4 ++++ .../uniworx/utils/handler_form/occurrences/en-eu.msg | 4 ++++ src/Foundation/Navigation.hs | 11 +++++++++-- src/Handler/School/DayTasks.hs | 11 ++++++++--- src/Import/NoModel.hs | 7 +++++++ src/Model/Types/DateTime.hs | 6 ------ 6 files changed, 32 insertions(+), 11 deletions(-) diff --git a/messages/uniworx/utils/handler_form/occurrences/de-de-formal.msg b/messages/uniworx/utils/handler_form/occurrences/de-de-formal.msg index e70c0a30d..24119b496 100644 --- a/messages/uniworx/utils/handler_form/occurrences/de-de-formal.msg +++ b/messages/uniworx/utils/handler_form/occurrences/de-de-formal.msg @@ -20,3 +20,7 @@ ExceptionNoOccurAt: Termin ExceptionKind: Termin ... ExceptionKindOccur: Findet statt ExceptionKindNoOccur: Findet nicht statt +DayNext: Folgetag +DayPrev: Vortag +WeekNext: Nächste Woche +WeekPrev: Vorherige Woche diff --git a/messages/uniworx/utils/handler_form/occurrences/en-eu.msg b/messages/uniworx/utils/handler_form/occurrences/en-eu.msg index 1c325ea7f..62f629add 100644 --- a/messages/uniworx/utils/handler_form/occurrences/en-eu.msg +++ b/messages/uniworx/utils/handler_form/occurrences/en-eu.msg @@ -20,3 +20,7 @@ ExceptionNoOccurAt: Event ExceptionKind: Event ... ExceptionKindOccur: Does occur ExceptionKindNoOccur: Does not occur +DayNext: Next day +DayPrev: Previous day +WeekNext: Next week +WeekPrev: Previous week \ No newline at end of file diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 0bf6d5306..bcd9f152a 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -1201,6 +1201,13 @@ pageActions SchoolListR = return , navChildren = [] } ] +pageActions (SchoolR ssh (SchoolDayR nd)) = return + [ NavPageActionPrimary + { navLink = defNavLink msg $ SchoolR ssh (SchoolDayR $ addDays n nd) + , navChildren = [] + } + | (msg, n) <- [(MsgWeekPrev, -7), (MsgDayPrev, -1), (MsgDayNext, 1), (MsgWeekNext, 7)] + ] pageActions UsersR = return [ NavPageActionPrimary { navLink = NavLink @@ -2583,7 +2590,7 @@ submissionList tid csh shn uid = withReaderT (projectBackend @SqlReadBackend) . E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid - E.&&. sheet E.^. SheetName E.==. E.val shn + E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseTerm E.==. E.val tid diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 846e1b615..29219e84a 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -82,17 +82,22 @@ mkDailyTable ssh nd = do EL.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse E.where_ $ course E.^. CourseSchool E.==. E.val ssh E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue nd)) - E.&&. E.exists $ do + E.&&. E.exists (do trm <- E.from $ E.table @Term E.where_ $ E.between (E.val nd) (trm E.^. TermStart, trm E.^. TermEnd) E.&&. trm E.^. TermId E.==. course E.^. CourseTerm + ) return (course, tut) dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtProj = dbtProjId dbtColonnade = mconcat [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) - sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal . _courseName . _CI -> t) -> textCell t - , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \(view $ resultTutorial . _entityVal . _tutorialName . _CI -> t) -> textCell t + sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c + , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row -> + let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh} + = row ^. resultCourse . _entityVal + tutName = row ^. resultTutorial . _entityVal . _tutorialName + in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName ] dbtSorting = Map.fromList [ ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index ac2fb34f5..adbc5df67 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -2,6 +2,8 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Import.NoModel ( module Import , MForm @@ -270,3 +272,8 @@ import Control.Monad.Trans.RWS (RWST) type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m type WeekDay = DayOfWeek + +-- TODO: maybe move elsewhere +deriving newtype instance NFData a => NFData (JSONB a) +deriving newtype instance Semigroup a => Semigroup (JSONB a) +deriving newtype instance Monoid a => Monoid (JSONB a) diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index b329ad68e..43c24a761 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -233,11 +233,6 @@ instance Semigroup Occurrences where instance Monoid Occurrences where mempty = Occurrences mempty mempty --- TODO: move elsewhere -deriving newtype instance NFData a => NFData (JSONB a) -deriving newtype instance Semigroup a => Semigroup (JSONB a) -deriving newtype instance Monoid a => Monoid (JSONB a) - jsonbOCCUR :: Maybe (JSONB Occurrences) -> Occurrences jsonbOCCUR = foldMap unJSONB @@ -248,7 +243,6 @@ _Occurrences :: Iso' (JSONB Occurrences) Occurrences _Occurrences = iso unJSONB JSONB - nullaryPathPiece ''DayOfWeek camelToPathPiece -- test :: IO [OccurrenceException] From ce62b99d2bdeef1fcd9a78a53a617cf9375c203b Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 13 Sep 2024 18:03:41 +0200 Subject: [PATCH 014/187] chore(daily): add more columns #90 --- src/Handler/LMS.hs | 7 +--- src/Handler/Qualification.hs | 7 +--- src/Handler/School/DayTasks.hs | 74 ++++++++++++++++++++++++---------- src/Handler/Utils/Company.hs | 17 +++++++- test/Database/Fill.hs | 4 +- 5 files changed, 74 insertions(+), 35 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 13f782661..9821c2309 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -29,6 +29,7 @@ import Jobs import Handler.Utils import Handler.Utils.Users import Handler.Utils.LMS +import Handler.Utils.Company import qualified Data.Set as Set @@ -420,11 +421,7 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this! E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder - primeComp = E.subSelect . E.from $ \uc -> do - E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser - E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany] - return (uc E.^. UserCompanyCompany) - return (qualUser, user, lmsUser, qualBlock, printAcknowledged, primeComp, validQualification now qualUser) + return (qualUser, user, lmsUser, qualBlock, printAcknowledged, selectCompanyUserPrime user, validQualification now qualUser) mkLmsTable :: ( Functor h, ToSortable h diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 6eee590d3..8ca169696 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -18,6 +18,7 @@ import Jobs import Handler.Utils import Handler.Utils.Users import Handler.Utils.LMS +import Handler.Utils.Company import qualified Data.Set as Set import qualified Data.Map as Map @@ -345,11 +346,7 @@ qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJo E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) - let primeComp = E.subSelect . E.from $ \uc -> do - E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser - E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany] - return (uc E.^. UserCompanyCompany) - return (qualUser, user, lmsUser, qualBlock, primeComp) + return (qualUser, user, lmsUser, qualBlock, selectCompanyUserPrime user) mkQualificationTable :: diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 29219e84a..29b27e86b 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -14,6 +14,7 @@ module Handler.School.DayTasks import Import import Handler.Utils +import Handler.Utils.Company -- import qualified Data.Set as Set import qualified Data.Map as Map @@ -55,17 +56,21 @@ occurrenceDayValue d = Aeson.object type DailyTableExpr = ( E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Tutorial) + `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) + `E.InnerJoin` E.SqlExpr (Entity User) ) queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) -queryCourse = $(sqlIJproj 2 1) - +queryCourse = $(sqlIJproj 4 1) queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) -queryTutorial = $(sqlIJproj 2 2) +queryTutorial = $(sqlIJproj 4 2) + +queryUser :: DailyTableExpr -> E.SqlExpr (Entity User) +queryUser = $(sqlIJproj 4 4) -type DailyTableData = DBRow (Entity Course, Entity Tutorial) +type DailyTableData = DBRow (Entity Course, Entity Tutorial, Entity User, E.Value (Maybe CompanyId)) resultCourse :: Lens' DailyTableData (Entity Course) resultCourse = _dbrOutput . _1 @@ -73,23 +78,36 @@ resultCourse = _dbrOutput . _1 resultTutorial :: Lens' DailyTableData (Entity Tutorial) resultTutorial = _dbrOutput . _2 +resultUser :: Lens' DailyTableData (Entity User) +resultUser = _dbrOutput . _3 -mkDailyTable :: SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) -mkDailyTable ssh nd = do +resultCompanyId :: Traversal' DailyTableData CompanyId +resultCompanyId = _dbrOutput . _4 . _unValue . _Just + +instance HasEntity DailyTableData User where + hasEntity = resultUser + +instance HasUser DailyTableData where + hasUser = resultUser . _entityVal + +mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) +mkDailyTable isAdmin ssh nd = do let - dbtSQLQuery :: DailyTableExpr -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial)) - dbtSQLQuery (course `E.InnerJoin` tut) = do - EL.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse - E.where_ $ course E.^. CourseSchool E.==. E.val ssh + dbtSQLQuery :: DailyTableExpr -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId))) + dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do + EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId + EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial + EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser + E.where_ $ crs E.^. CourseSchool E.==. E.val ssh E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue nd)) E.&&. E.exists (do trm <- E.from $ E.table @Term - E.where_ $ E.between (E.val nd) (trm E.^. TermStart, trm E.^. TermEnd) - E.&&. trm E.^. TermId E.==. course E.^. CourseTerm + E.where_ $ trm E.^. TermId E.==. crs E.^. CourseTerm + E.&&. E.between (E.val nd) (trm E.^. TermStart, trm E.^. TermEnd) ) - return (course, tut) + return (crs, tut, usr, selectCompanyUserPrime usr) dbtRowKey = queryTutorial >>> (E.^. TutorialId) - dbtProj = dbtProjId + dbtProj = dbtProjId dbtColonnade = mconcat [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c @@ -98,19 +116,30 @@ mkDailyTable ssh nd = do = row ^. resultCourse . _entityVal tutName = row ^. resultTutorial . _entityVal . _tutorialName in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName + , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid + , colUserNameModalHdr MsgTableCourseMembers ForProfileDataR + , colUserMatriclenr isAdmin ] dbtSorting = Map.fromList - [ ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) + [ sortUserNameLink queryUser + , sortUserMatriclenr queryUser + , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) + , ("user-company", SortColumn $ queryUser >>> selectCompanyUserPrime) ] dbtFilter = Map.fromList - [ ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName)) - , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName)) + [ fltrUserNameEmail queryUser + , fltrUserMatriclenr queryUser + , ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName)) + , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName)) + , ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser >>> selectCompanyUserPrime) ] dbtFilterUI mPrev = mconcat - [ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse) - , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial) - + [ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse) + , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial) + , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompany) + , fltrUserNameEmailUI mPrev + , fltrUserMatriclenrUI mPrev ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} dbtIdent :: Text @@ -143,15 +172,16 @@ mkDailyTable ssh nd = do (First (Just act), jobMap) <- inp let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap return (act, jobSet) - psValidator = def & defaultSorting [SortAscBy "course", SortAscBy "tutorial"] + psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"] over _1 postprocess <$> dbTable psValidator DBTable{..} getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html getSchoolDayR = postSchoolDayR postSchoolDayR ssh nd = do + isAdmin <- hasReadAccessTo AdminR dday <- formatTime SelFormatDate nd - (_,tableDaily) <- runDB $ mkDailyTable ssh nd + (_,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do setTitleI (MsgMenuSchoolDay ssh dday) [whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)} diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 86f88ef03..c8dad2968 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -2,6 +2,8 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Handler.Utils.Company where @@ -21,6 +23,9 @@ import qualified Database.Esqueleto.PostgreSQL as E import Handler.Utils.Users import Handler.Utils.Widgets +-- KeyCompany is CompanyShorthand, i.e. CI Text +instance E.SqlString (Key Company) + -- Snippet to restrict to primary company only -- E.&&. E.notExists (do -- othr <- E.from $ E.table @UserCompany @@ -233,7 +238,8 @@ deleteDefaultSupervisorsForUsers cids sprs usrs = $ bcons (notNull sprs) (UserSupervisorSupervisor <-. sprs) $ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter --- | retrieve maximum company user priority fo a user +-- | retrieve maximum company user priority for a user + getCompanyUserMaxPrio :: UserId -> DB Int getCompanyUserMaxPrio uid = do mbMaxPrio <- E.selectOne $ do @@ -241,3 +247,12 @@ getCompanyUserMaxPrio uid = do E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid return . E.max_ $ usrCmp E.^. UserCompanyPriority return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio + +-- | retrieve maximum company user priority for a user within SQL query +-- Note: if there a multiple top-companies, only one is returned +selectCompanyUserPrime :: E.SqlExpr (Entity User) -> E.SqlExpr (E.Value (Maybe CompanyId)) +selectCompanyUserPrime usr = E.subSelect $ do + uc <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserId E.==. uc E.^. UserCompanyUser + E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany] + return (uc E.^. UserCompanyCompany) \ No newline at end of file diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index f1047d2ef..4e05a2d04 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -86,7 +86,7 @@ fillDb = do , userAuthentication = AuthLDAP , userLastAuthentication = Just now , userTokensIssuedAfter = Just now - , userMatrikelnummer = Nothing + , userMatrikelnummer = Just 999 , userEmail = "G.Kleen@campus.lmu.de" , userDisplayEmail = "gregor.kleen@ifi.lmu.de" , userDisplayName = "Gregor Kleen" @@ -292,7 +292,7 @@ fillDb = do , userAuthentication = AuthLDAP , userLastAuthentication = Nothing , userTokensIssuedAfter = Nothing - , userMatrikelnummer = Nothing + , userMatrikelnummer = Just 365 , userEmail = "vaupel.sarah@campus.lmu.de" , userDisplayEmail = "vaupel.sarah@campus.lmu.de" , userDisplayName = "Sarah Vaupel" From 1d0189775789e4bbafb119db815ad9f7f3c75614 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 16 Sep 2024 17:16:19 +0200 Subject: [PATCH 015/187] chore(daily): make company a property of TutorialParticipant, towards #90 --- .../courses/tutorial/de-de-formal.msg | 1 + .../categories/courses/tutorial/en-eu.msg | 1 + .../utils/table_column/de-de-formal.msg | 1 + messages/uniworx/utils/table_column/en-eu.msg | 1 + models/tutorials.model | 1 + src/Database/Esqueleto/Utils.hs | 6 ++-- src/Foundation/Authorization.hs | 26 ++++++++-------- src/Foundation/Navigation.hs | 2 +- src/Handler/Course/ParticipantInvite.hs | 2 ++ src/Handler/Course/Users.hs | 10 +++++-- src/Handler/Exam/Form.hs | 6 ++-- src/Handler/School/DayTasks.hs | 30 ++++++++++++------- src/Handler/Sheet/Download.hs | 4 +-- src/Handler/Sheet/Show.hs | 2 +- src/Handler/Tutorial/Register.hs | 9 ++++-- src/Handler/Utils/AuthorshipStatement.hs | 4 +-- src/Handler/Utils/Company.hs | 15 ++++++++-- src/Handler/Utils/Files.hs | 18 +++++------ src/Handler/Utils/Term.hs | 6 ++-- src/Handler/Utils/Users.hs | 9 +++--- src/Utils/Lens.hs | 1 + test/Database/Fill.hs | 22 +++++++------- 22 files changed, 108 insertions(+), 69 deletions(-) diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 5a4cef6b6..b0e631340 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -36,6 +36,7 @@ TutorialDelete: Löschen TutorialsHeading: Kurse TutorialNew: Neuer Kurs TutorialRegisteredSuccess tutn@TutorialName: Erfolgreich zum Kurs #{tutn} angemeldet +TutorialRegisteredFail tutn@TutorialName: Anmeldung zum Kurs #{tutn} fehlgeschlagen. Existiert bereits eine Anmeldung? TutorialDeregisteredSuccess tutn@TutorialName: Erfolgreich vom Kurs #{tutn} abgemeldet MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{tid}-#{ssh}-#{csh}] Einladung zum Ausbilder für #{tutn} TutorInviteHeading tutn@TutorialName: Einladung zum Ausbilder/zur Ausbilderin für #{tutn} diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 20df36d50..a3afdf94f 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -36,6 +36,7 @@ TutorialDelete: Delete TutorialsHeading: Courses TutorialNew: New course TutorialRegisteredSuccess tutn: Successfully registered for the course #{tutn} +TutorialRegisteredFail tutn: Registering for the course #{tutn} failed. Probably already registered? TutorialDeregisteredSuccess tutn: Successfully de-registered for the course #{tutn} MailSubjectTutorInvitation tid ssh csh tutn: [#{tid}-#{ssh}-#{csh}] Invitation to be a instructor for #{tutn} TutorInviteHeading tutn: Invitation to be instructor for #{tutn} diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 8597a7c2c..5e658cb43 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -80,6 +80,7 @@ TableCompanyFilter: Firma oder Nummer TableCompanyShort: Firmenkürzel TableCompanies: Firmen TablePrimeCompany: Primäre Firma +TableBookingCompany: Buchende Firma TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern TableCompanyUser: Firmenangehöriger diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index d489426c1..97d3ba9cc 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -80,6 +80,7 @@ TableCompanyFilter: Company/Nr TableCompanyShort: Company shorthand TableCompanies: Companies TablePrimeCompany: Primary company +TableBookingCompany: Booking company TableCompanyNo: Company number TableCompanyNos: Company numbers TableCompanyUser: Associate diff --git a/models/tutorials.model b/models/tutorials.model index e7e21e8b2..173f7862c 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -27,6 +27,7 @@ Tutor TutorialParticipant tutorial TutorialId OnDeleteCascade OnUpdateCascade user UserId + company CompanyId Maybe UniqueTutorialParticipant tutorial user deriving Eq Ord Show deriving Generic \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 3052f652f..152d506ae 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -49,7 +49,6 @@ module Database.Esqueleto.Utils , unKey , subSelectCountDistinct , selectCountRows, selectCountDistinct - , selectMaybe , str2text, str2text' , num2text --, text2num , day, day', dayMaybe, interval, diffDays, diffTimes @@ -739,8 +738,9 @@ selectCountDistinct q = do _other -> error "E.countDistinct did not return exactly one result" -selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) -selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) +-- DEPRECATED: use Database.Esqueleto.selectOne instead +-- selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) +-- selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) -- | convert something that is like a text to text str2text :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Text) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 0243b0609..7e0812297 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -38,7 +38,7 @@ import Handler.Utils.I18n import Handler.Utils.Routes import Utils.Course (courseIsVisible) import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..)) - + import qualified Data.Set as Set import qualified Data.Aeson as JSON import qualified Data.HashSet as HashSet @@ -95,7 +95,7 @@ instance Exception InvalidAuthTag type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult - + data AccessPredicate = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) | APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult) @@ -174,7 +174,7 @@ cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do v <- mkV memcachedBySet mExp k v either (return . Left) (fmap Right . lift) $ cont mAuthId route isWrite v - + -- cacheAP' :: ( Binary k -- , Typeable v, Binary v -- ) @@ -185,7 +185,7 @@ cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do -- cacheAP' mExp mkKV cont = APBind $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of -- Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV -- Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing - + cacheAPDB' :: ( Binary k , Typeable v, Binary v, NFData v ) @@ -538,14 +538,14 @@ tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right d guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) return Authorized -tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of +tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of ForProfileR cID -> checkSupervisor (mAuthId, cID) ForProfileDataR cID -> checkSupervisor (mAuthId, cID) FirmAllR -> checkAnySupervisor mAuthId FirmUsersR fsh -> checkCompanySupervisor (mAuthId, fsh) FirmSupersR fsh -> checkCompanySupervisor (mAuthId, fsh) - r -> $unsupportedAuthPredicate AuthSupervisor r - where + r -> $unsupportedAuthPredicate AuthSupervisor r + where checkSupervisor sup@(mAuthId, cID) = $cachedHereBinary sup . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId uid <- decrypt cID @@ -553,13 +553,13 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedSupervisor) return Authorized checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId -- isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh isSupervisor <- lift $ exists [UserCompanyUser ==. authId, UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True] guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh) return Authorized checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId isSupervisor <- lift $ exists [UserSupervisorSupervisor ==. authId] guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedAnySupervisor) return Authorized @@ -692,7 +692,7 @@ tagAccessPredicate AuthLecturer = cacheAPDB' (Just $ Right diffMinute) mkLecture _ | is _Nothing mAuthId' -> return AuthenticationRequired CourseR{} -> unauthorizedI MsgUnauthorizedLecturer EExamR{} -> unauthorizedI MsgUnauthorizedExternalExamLecturer - _other -> unauthorizedI MsgUnauthorizedSchoolLecturer + _other -> unauthorizedI MsgUnauthorizedSchoolLecturer | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId @@ -722,7 +722,7 @@ tagAccessPredicate AuthLecturer = cacheAPDB' (Just $ Right diffMinute) mkLecture return Authorized where mkLecturerList _ route _ = case route of - CourseR{} -> cacheLecturerList + CourseR{} -> cacheLecturerList EExamR{} -> Just ( AuthCacheExternalExamStaffList , fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExternalExamStaffUser) @@ -1199,7 +1199,7 @@ tagAccessPredicate AuthExamRegistered = APDB $ \_ _ mAuthId route _ -> case rout guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredExam return Authorized CSheetR tid ssh csh shn _ -> exceptT return return $ do - requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectMaybe . E.from $ \(course `E.InnerJoin` sheet) -> do + requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectOne . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh @@ -1700,7 +1700,7 @@ evalAccessWith :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] - evalAccessWith assumptions route isWrite = do mAuthId <- liftHandler maybeAuthId evalAccessWithFor assumptions mAuthId route isWrite - + evalAccessWithDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessWithDB = evalAccessWith diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index bcd9f152a..367fe7a21 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -1988,7 +1988,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do { navLabel = MsgMenuSheetPersonalisedFiles , navRoute = CSheetR tid ssh csh shn SPersonalFilesR , navAccess' = NavAccessDB $ - let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do + let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectOne . E.from $ \(sheet `E.InnerJoin` course) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_$ sheet E.^. SheetName E.==. E.val shn E.&&. course E.^. CourseTerm E.==. E.val tid diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index c000c9c2b..538d4d68a 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -13,6 +13,7 @@ import Import import Handler.Utils import Handler.Utils.Avs +import Handler.Utils.Company import Jobs.Queue @@ -401,6 +402,7 @@ registerTutorialMembers :: TutorialId -> Set UserId -> Handler () registerTutorialMembers tutId (Set.toList -> users) = runDB $ do prevParticipants <- Set.fromList . fmap entityKey <$> selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] [] participants <- fmap Set.fromList . for users $ \tutorialParticipantUser -> do + tutorialParticipantCompany <- selectCompanyUserPrime' tutorialParticipantUser Entity tutPartId _ <- upsert TutorialParticipant { tutorialParticipantTutorial = tutId, .. } [] audit $ TransactionTutorialParticipantEdit tutId tutPartId tutorialParticipantUser return tutPartId diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index b8a04f31e..3d66e30c7 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -18,6 +18,7 @@ import Import import Utils.Form import Handler.Utils import Handler.Utils.Course +import Handler.Utils.Company import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.PostgreSQL as E import Database.Esqueleto.Utils.TH @@ -733,9 +734,12 @@ postCUsersR tid ssh csh = do addMessageI Success $ MsgCourseUsersDeregistered nrDel redirect $ CourseR tid ssh csh CUsersR (CourseUserRegisterTutorialData{..}, selectedUsers) -> do - runDB . forM_ selectedUsers $ - void . insertUnique . TutorialParticipant registerTutorial - addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers + Sum nrOk <- runDB $ flip foldMapM selectedUsers $ \uid -> do + fsh <- selectCompanyUserPrime' uid + mbKey <- insertUnique $ TutorialParticipant registerTutorial uid fsh + return $ Sum $ length mbKey + let mStatus = bool Success Warning $ nrOk < Set.size selectedUsers + addMessageI mStatus $ MsgCourseUsersTutorialRegistered $ fromIntegral nrOk redirect $ CourseR tid ssh csh CUsersR (CourseUserRegisterExamData{..}, selectedUsers) -> do Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 34277e5cb..4d5d5e958 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -23,7 +23,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.Utils as E import qualified Control.Monad.State.Class as State import Text.Blaze.Html.Renderer.Text (renderHtml) @@ -419,7 +419,7 @@ examTemplate cid = runMaybeT $ do E.limit 1 E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ] return (course, exam, authorshipStatementDefinition) - + extraSchools <- lift $ selectList [ ExamOfficeSchoolExam ==. oldExamId ] [] oldTerm <- MaybeT . get $ courseTerm oldCourse @@ -517,7 +517,7 @@ validateExam cId oldExam = do .| C.mapM_ (\(Entity _ Sheet{..}) -> guardValidationM (MsgExamPartCannotBeDeletedDueToSheetReference epNumber sheetName) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId) - mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do + mSchool <- liftHandler . runDB . E.selectOne . E.from $ \(course `E.InnerJoin` school) -> do E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId E.where_ $ course E.^. CourseId E.==. E.val cId return school diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 29b27e86b..db154a960 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -59,6 +59,8 @@ type DailyTableExpr = `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) `E.InnerJoin` E.SqlExpr (Entity User) ) +type DailyTableOutput = E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity TutorialParticipant), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId))) +type DailyTableData = DBRow (Entity Course, Entity Tutorial, Entity TutorialParticipant, Entity User, E.Value (Maybe CompanyId)) queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) queryCourse = $(sqlIJproj 4 1) @@ -66,23 +68,29 @@ queryCourse = $(sqlIJproj 4 1) queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) queryTutorial = $(sqlIJproj 4 2) +queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant) +queryParticipant = $(sqlIJproj 4 3) + queryUser :: DailyTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlIJproj 4 4) - -type DailyTableData = DBRow (Entity Course, Entity Tutorial, Entity User, E.Value (Maybe CompanyId)) - resultCourse :: Lens' DailyTableData (Entity Course) resultCourse = _dbrOutput . _1 resultTutorial :: Lens' DailyTableData (Entity Tutorial) resultTutorial = _dbrOutput . _2 +resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant) +resultParticipant = _dbrOutput . _3 + +-- resultCompanyId :: Traversal' DailyTableData CompanyId +-- resultCompanyId = _dbrOutput . _3 . _entityVal . _tutorialParticipantCompany . _Just + resultUser :: Lens' DailyTableData (Entity User) -resultUser = _dbrOutput . _3 +resultUser = _dbrOutput . _4 resultCompanyId :: Traversal' DailyTableData CompanyId -resultCompanyId = _dbrOutput . _4 . _unValue . _Just +resultCompanyId = _dbrOutput . _5 . _unValue . _Just instance HasEntity DailyTableData User where hasEntity = resultUser @@ -93,7 +101,7 @@ instance HasUser DailyTableData where mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do let - dbtSQLQuery :: DailyTableExpr -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId))) + dbtSQLQuery :: DailyTableExpr -> DailyTableOutput dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial @@ -105,7 +113,7 @@ mkDailyTable isAdmin ssh nd = do E.where_ $ trm E.^. TermId E.==. crs E.^. CourseTerm E.&&. E.between (E.val nd) (trm E.^. TermStart, trm E.^. TermEnd) ) - return (crs, tut, usr, selectCompanyUserPrime usr) + return (crs, tut, tpu, usr, selectCompanyUserPrime usr) dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtProj = dbtProjId dbtColonnade = mconcat @@ -117,15 +125,17 @@ mkDailyTable isAdmin ssh nd = do tutName = row ^. resultTutorial . _entityVal . _tutorialName in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid + , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid , colUserNameModalHdr MsgTableCourseMembers ForProfileDataR , colUserMatriclenr isAdmin ] dbtSorting = Map.fromList [ sortUserNameLink queryUser , sortUserMatriclenr queryUser - , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) - , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) - , ("user-company", SortColumn $ queryUser >>> selectCompanyUserPrime) + , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) + , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) + , ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime) + , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany)) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser diff --git a/src/Handler/Sheet/Download.hs b/src/Handler/Sheet/Download.hs index 08830b584..40bdded68 100644 --- a/src/Handler/Sheet/Download.hs +++ b/src/Handler/Sheet/Download.hs @@ -66,7 +66,7 @@ getSArchiveR tid ssh csh shn = do | otherwise = f & _FileReference . _1 . _fileReferenceTitle %~ (unpack (mr $ SheetArchiveFileTypeDirectory (sft f)) ) sftDirectories <- if | not multipleSFTs -> return mempty - | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \(sFile `E.FullOuterJoin` psFile) -> do + | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectOne . E.from $ \(sFile `E.FullOuterJoin` psFile) -> do E.on $ sFile E.?. SheetFileSheet E.==. psFile E.?. PersonalisedSheetFileSheet E.&&. sFile E.?. SheetFileType E.==. psFile E.?. PersonalisedSheetFileType E.&&. sFile E.?. SheetFileTitle E.==. psFile E.?. PersonalisedSheetFileTitle @@ -78,7 +78,7 @@ getSArchiveR tid ssh csh shn = do [ sFile E.?. SheetFileModified , psFile E.?. PersonalisedSheetFileModified ] - + serveZipArchive archiveName $ do forM_ sftDirectories $ \(sft, mTime) -> yield . Left $ SheetFile { sheetFileType = sft diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs index 62a25cf60..1bdc42880 100644 --- a/src/Handler/Sheet/Show.hs +++ b/src/Handler/Sheet/Show.hs @@ -128,7 +128,7 @@ getSShowR tid ssh csh shn = do [ wouldHaveWriteAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SubmissionNewR , wouldHaveReadAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SArchiveR ] - mRequiredExam <- fmap join . for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectMaybe . E.from $ \(exam `E.InnerJoin` course) -> do + mRequiredExam <- fmap join . for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectOne . E.from $ \(exam `E.InnerJoin` course) -> do E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId E.where_ $ exam E.^. ExamId E.==. E.val eId return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, exam E.^. ExamName) diff --git a/src/Handler/Tutorial/Register.hs b/src/Handler/Tutorial/Register.hs index 06471ead8..0377aae60 100644 --- a/src/Handler/Tutorial/Register.hs +++ b/src/Handler/Tutorial/Register.hs @@ -9,6 +9,7 @@ module Handler.Tutorial.Register import Import import Handler.Utils import Handler.Utils.Tutorial +import Handler.Utils.Company postTRegisterR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler () @@ -21,8 +22,12 @@ postTRegisterR tid ssh csh tutn = do formResult btnResult $ \case BtnRegister -> do - runDB . void . insert $ TutorialParticipant tutid uid - addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName + ok <- runDB $ do + fsh <- selectCompanyUserPrime' uid + insertUnique $ TutorialParticipant tutid uid fsh + if isJust ok + then addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName + else addMessageI Error $ MsgTutorialRegisteredFail tutorialName -- cannot happen, but it is nonetheless better to be safe than crashing redirect $ CourseR tid ssh csh CShowR BtnDeregister -> do runDB . deleteBy $ UniqueTutorialParticipant tutid uid diff --git a/src/Handler/Utils/AuthorshipStatement.hs b/src/Handler/Utils/AuthorshipStatement.hs index 2832bdd86..ddc455e1a 100644 --- a/src/Handler/Utils/AuthorshipStatement.hs +++ b/src/Handler/Utils/AuthorshipStatement.hs @@ -18,7 +18,7 @@ import qualified Data.Map.Strict as Map import Handler.Utils.Form (i18nLangMap, I18nLang(..)) import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.Utils as E import qualified Data.ByteString.Base64.URL as Base64 import qualified Data.ByteArray as BA @@ -81,7 +81,7 @@ getSheetAuthorshipStatement :: MonadIO m => Entity Sheet -> SqlReadT m (Maybe (Entity AuthorshipStatementDefinition)) getSheetAuthorshipStatement (Entity _ Sheet{..}) = withCompatibleBackend @SqlBackend $ traverse getJustEntity <=< runMaybeT $ do - Entity _ School{..} <- MaybeT . E.selectMaybe . E.from $ \(school `E.InnerJoin` course) -> do + Entity _ School{..} <- MaybeT . E.selectOne . E.from $ \(school `E.InnerJoin` course) -> do E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool E.where_ $ course E.^. CourseId E.==. E.val sheetCourse return school diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index c8dad2968..ffa2f015f 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -251,8 +251,19 @@ getCompanyUserMaxPrio uid = do -- | retrieve maximum company user priority for a user within SQL query -- Note: if there a multiple top-companies, only one is returned selectCompanyUserPrime :: E.SqlExpr (Entity User) -> E.SqlExpr (E.Value (Maybe CompanyId)) -selectCompanyUserPrime usr = E.subSelect $ do +selectCompanyUserPrime usr = E.subSelect $ selectCompanyUserPrimeHelper $ usr E.^. UserId + +-- | like @selectCompanyUserPrime@, but directly usable, a simpler type to think about it `UserId -> DB (Maybe CompanyId)` +selectCompanyUserPrime' :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend) + => UserId -> ReaderT backend m (Maybe CompanyId) +selectCompanyUserPrime' uid = fmap E.unValue <<$>> E.selectOne $ selectCompanyUserPrimeHelper $ E.val uid + +-- selectCompanyUserPrime'' :: UserId -> DB (Maybe CompanyId) +-- selectCompanyUserPrime'' uid = (userCompanyCompany . entityVal) <<$>> selectMaybe [UserCompanyUser ==. uid] [Desc UserCompanyPriority, Asc UserCompanyCompany] + +selectCompanyUserPrimeHelper :: E.SqlExpr (E.Value UserId) -> E.SqlQuery (E.SqlExpr (E.Value CompanyId)) +selectCompanyUserPrimeHelper uid = do uc <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserId E.==. uc E.^. UserCompanyUser + E.where_ $ uc E.^. UserCompanyUser E.==. uid E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany] return (uc E.^. UserCompanyCompany) \ No newline at end of file diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index 07b777643..cd91cc79f 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -62,7 +62,7 @@ fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do let w = length chunk in liftIO $ observeSourcedChunk storage w Just lh -> do - chunkRes <- lookupLRUHandle lh k + chunkRes <- lookupLRUHandle lh k case chunkRes of Just (chunk, w) -> Just chunk <$ do $logDebugS "fileChunkARC" "Prewarm hit" @@ -74,7 +74,7 @@ fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do for_ mStorage $ \storage -> let w = length chunk in liftIO $ observeSourcedChunk storage w - + arc <- getsYesod appFileSourceARC case arc of Nothing -> getChunkDB @@ -97,7 +97,7 @@ fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do liftIO $ Just x <$ observeSourcedChunk StorageARC w - + sourceFileDB :: forall m. (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) => FileContentReference -> ConduitT () ByteString (SqlPersistT m) () @@ -119,7 +119,7 @@ sourceFileChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlRe Nothing -> return Nothing Just start -> do let getChunkDB = cont (start, dbChunksize) . runMaybeT $ - let getChunkDB' = MaybeT . fmap (fmap $ (, StorageDB) . E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do + let getChunkDB' = MaybeT . fmap (fmap $ (, StorageDB) . E.unValue) . E.selectOne . E.from $ \fileContentChunk -> do E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize) getChunkMinio = fmap (, StorageMinio) . catchIfMaybeT (is _SourceFilesContentUnavailable) . runConduit $ sourceMinio (Left chunkHash) (Just $ ByteRangeFromTo (fromIntegral $ pred start) (fromIntegral . pred $ pred start + dbChunksize)) .| C.fold @@ -191,7 +191,7 @@ sourceFile' = sourceFile . view (_FileReference . _1) instance (YesodMail UniWorX, YesodPersistBackend UniWorX ~ SqlBackend) => ToMailPart UniWorX FileReference where toMailPart = toMailPart <=< liftHandler . runDBRead . withReaderT projectBackend . toPureFile . sourceFile' - + respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, YesodPersistRunner UniWorX) => Maybe UTCTime -> MimeType @@ -253,7 +253,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do forM_ relevantChunks $ \(chunkHash, offset, cLength) -> let retrieveChunk = \case Just (start, cLength') | cLength' > 0 -> do - let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do + let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectOne . E.from $ \fileContentChunk -> do E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize) chunk <- fileChunkARC (Just $ fromIntegral dbChunksize) (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB @@ -270,7 +270,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do , ByteContentRangeSpecification (Just $ ByteRangeResponseSpecification byteFrom byteTo) (Just iLength) ) | otherwise -> throwM SourceFilesContentUnavailable - + | otherwise -> return $ sendResponseStatus noContent204 () where @@ -281,7 +281,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do , requestedActionAlreadySucceeded = Nothing } -byteRangeSpecificationToMinio :: Word64 -> ByteRangeSpecification -> (ByteRange, ByteRangeResponseSpecification) +byteRangeSpecificationToMinio :: Word64 -> ByteRangeSpecification -> (ByteRange, ByteRangeResponseSpecification) byteRangeSpecificationToMinio iLength byteRange = (byteRange', respRange) where byteRange' = case byteRange of @@ -293,7 +293,7 @@ byteRangeSpecificationToMinio iLength byteRange = (byteRange', respRange) ByteRangeSpecification f (Just t) -> ByteRangeResponseSpecification (min (pred iLength) f) (min (pred iLength) t) ByteRangeSuffixSpecification s -> ByteRangeResponseSpecification (iLength - min (pred iLength) s) (pred iLength) - + acceptFile :: (MonadResource m, MonadResource m') => FileInfo -> m (File m') acceptFile fInfo = do let fileTitle = "." unpack (fileName fInfo) diff --git a/src/Handler/Utils/Term.hs b/src/Handler/Utils/Term.hs index 841082745..623285e93 100644 --- a/src/Handler/Utils/Term.hs +++ b/src/Handler/Utils/Term.hs @@ -16,7 +16,7 @@ import qualified Data.Set as Set import qualified Data.Sequence as Seq import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.Utils as E import Utils.Term @@ -41,7 +41,7 @@ getCurrentTerm :: MonadIO m => SqlReadT m (Maybe TermId) -- ^ Current, generally active, term (i.e. `termIsActiveE` with `Nothing` as `maybeAuthId`) getCurrentTerm = do now <- liftIO getCurrentTime - fmap (fmap E.unValue) . E.selectMaybe . E.from $ \term -> do + fmap (fmap E.unValue) . E.selectOne . E.from $ \term -> do E.where_ . termIsActiveE (E.val now) E.nothing $ term E.^. TermId E.orderBy [E.desc $ term E.^. TermName] return $ term E.^. TermId @@ -64,7 +64,7 @@ getActiveTerms = do E.selectSource activeTermsQuery .| C.map E.unValue .| C.sinkList fetchTermByCID :: ( MonadHandler m - , BackendCompatible SqlBackend backend + , BackendCompatible SqlBackend backend , PersistQueryRead backend, PersistUniqueRead backend ) => CourseId -> ReaderT backend m Term diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index edffdaef1..1760d37fe 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -704,7 +704,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamRegistrationUser ==. oldUserId ] do - collision <- E.selectMaybe . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do + collision <- E.selectOne . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do EL.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId @@ -726,7 +726,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamPartResultUser ==. oldUserId ] do - collision <- E.selectMaybe . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do + collision <- E.selectOne . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do EL.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId @@ -816,7 +816,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector do - collision <- E.selectMaybe . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do + collision <- E.selectOne . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do EL.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle @@ -852,7 +852,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do (\_current _excluded -> []) do - collision <- E.selectMaybe . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do + collision <- E.selectOne . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId EL.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId @@ -870,6 +870,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do return $ TutorialParticipant E.<# (tutorialParticipant E.^. TutorialParticipantTutorial) E.<&> E.val newUserId + E.<&> (tutorialParticipant E.^. TutorialParticipantCompany) ) (\_current _excluded -> []) deleteWhere [ TutorialParticipantUser ==. oldUserId ] diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index f44763c48..eaff72ba0 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -281,6 +281,7 @@ makeLenses_ ''CourseUserExamOfficeOptOut makeLenses_ ''CourseNewsFile makeLenses_ ''Tutorial +makeLenses_ ''TutorialParticipant makeLenses_ ''SessionFile diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 4e05a2d04..e30296c56 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -86,7 +86,7 @@ fillDb = do , userAuthentication = AuthLDAP , userLastAuthentication = Just now , userTokensIssuedAfter = Just now - , userMatrikelnummer = Just 999 + , userMatrikelnummer = Just "99" , userEmail = "G.Kleen@campus.lmu.de" , userDisplayEmail = "gregor.kleen@ifi.lmu.de" , userDisplayName = "Gregor Kleen" @@ -292,7 +292,7 @@ fillDb = do , userAuthentication = AuthLDAP , userLastAuthentication = Nothing , userTokensIssuedAfter = Nothing - , userMatrikelnummer = Just 365 + , userMatrikelnummer = Just "365" , userEmail = "vaupel.sarah@campus.lmu.de" , userDisplayEmail = "vaupel.sarah@campus.lmu.de" , userDisplayName = "Sarah Vaupel" @@ -1075,7 +1075,7 @@ fillDb = do Thursday -> "A380" _ -> "B777" , tutorialRoomHidden = False - , tutorialTime = Occurrences + , tutorialTime = JSONB $ Occurrences { occurrencesScheduled = Set.fromList [ ScheduleWeekly { scheduleDayOfWeek = Thursday @@ -1132,7 +1132,7 @@ fillDb = do Thursday -> "A380" _ -> "B777" , tutorialRoomHidden = False - , tutorialTime = Occurrences + , tutorialTime = JSONB $ Occurrences { occurrencesScheduled = Set.empty , occurrencesExceptions = Set.fromList [ ExceptOccur @@ -1177,7 +1177,7 @@ fillDb = do Thursday -> "A380" _ -> "B777" , tutorialRoomHidden = False - , tutorialTime = Occurrences + , tutorialTime = JSONB $ Occurrences { occurrencesScheduled = Set.empty , occurrencesExceptions = Set.fromList [ ExceptOccur @@ -1209,12 +1209,12 @@ fillDb = do insert_ $ CourseParticipant c gkleen now $ CourseParticipantInactive True insert_ $ CourseParticipant c fhamann now $ CourseParticipantInactive False insert_ $ CourseParticipant c svaupel now CourseParticipantActive - insert_ $ TutorialParticipant tut1 svaupel - insert_ $ TutorialParticipant tut2 svaupel - when (odd tyear) $ insert_ $ TutorialParticipant tut3 svaupel - insert_ $ TutorialParticipant tut1 gkleen - insert_ $ TutorialParticipant tut2 fhamann - when (even tyear) $ insert_ $ TutorialParticipant tut3 jost + insert_ $ TutorialParticipant tut1 svaupel Nothing + insert_ $ TutorialParticipant tut2 svaupel $ Just fraGround + when (odd tyear) $ insert_ $ TutorialParticipant tut3 svaupel $ Just fraGround + insert_ $ TutorialParticipant tut1 gkleen $ Just nice + insert_ $ TutorialParticipant tut2 fhamann $ Just bpol + when (even tyear) $ insert_ $ TutorialParticipant tut3 jost $ Just fraportAg when (odd tyear) $ void . insert' $ Exam { examCourse = c From 3bae365b37c4ff1c603745c904bc8b47684f5d35 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 17 Sep 2024 12:56:49 +0200 Subject: [PATCH 016/187] chore(lpr): improve lpr log display --- src/Handler/PrintCenter.hs | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 1bacb9a47..167704c4d 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -519,23 +519,25 @@ getPrintLogR = do dbtIdent = "lpr-log" :: Text dbtSQLQuery l = do - E.where_ $ E.val "LPR" E.==. l E.^. TransactionLogInfo E.->>. "interface-name" - -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary + E.where_ $ (l E.^. TransactionLogInfo E.->>. "interface-name") `E.in_` E.valList ["LPR", "LETTER","APC", "Printer"] + -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary return l dbtRowKey = (E.^. TransactionLogId) dbtProj = dbtProjSimple $ \(Entity _ l) -> do return (l, Aeson.fromJSON $ transactionLogInfo l) dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t - , sortable (Just "status") (textCell "Status") $ tCell (cellMaybe iconBoolCell . transactionInterfaceSuccess) - , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype) $ tCell ( textCell . transactionInterfaceSubtype) - , sortable (Just "info") (i18nCell MsgSystemMessageContent) $ tCellErr ( textCell . transactionInterfaceInfo) + [ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t + , sortable (Just "status") (textCell "Status" ) $ tCell (cellMaybe iconBoolCell . transactionInterfaceSuccess) + , sortable (Just "interface") (i18nCell MsgInterfaceName ) $ tCell ( tellCell . transactionInterfaceName) + , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ tCell ( textCell . transactionInterfaceSubtype) + , sortable (Just "info") (i18nCell MsgSystemMessageContent ) $ tCellErr ( textCell . transactionInterfaceInfo) ] dbtSorting = mconcat - [ singletonMap "time" $ SortColumn (E.^. TransactionLogTime) - , singletonMap "status" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-success") - , singletonMap "subtype" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-subtype") - , singletonMap "info" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-info" ) + [ singletonMap "time" $ SortColumn (E.^. TransactionLogTime) + , singletonMap "status" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-success") + , singletonMap "interface" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-name" ) + , singletonMap "subtype" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-subtype") + , singletonMap "info" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-info" ) ] dbtFilter = mempty dbtFilterUI = mempty From 0105aa8c3fba0c106a4d7efbcf9b8ac88da2dff1 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 17 Sep 2024 12:57:31 +0200 Subject: [PATCH 017/187] refactor(model): move JSONB instance to proper module --- load/Load.hs | 20 ++++++++++---------- src/Import/NoModel.hs | 6 ------ src/Model/Types/Common.hs | 11 +++++++++-- src/Model/Types/DateTime.hs | 1 + 4 files changed, 20 insertions(+), 18 deletions(-) diff --git a/load/Load.hs b/load/Load.hs index 843127132..fd1c47886 100644 --- a/load/Load.hs +++ b/load/Load.hs @@ -96,7 +96,7 @@ sampleIntegral = sampleN scaleIntegral instance PathPiece DiffTime where toPathPiece = (toPathPiece :: Pico -> Text) . MkFixed . diffTimeToPicoseconds fromPathPiece t = fromPathPiece t <&> \(MkFixed ps :: Pico) -> picosecondsToDiffTime ps - + data LoadSimulation = LoadSheetDownload @@ -214,13 +214,13 @@ runSimulation sim = do delays <- replicateM (fromIntegral p) $ do d <- view $ _2 . _simDelay sampleNDiffTime d - + forConcurrently_ ([1..p] `zip` sort delays) $ \(n, d') -> do begin <- liftIO getCurrentTime dur <- view $ _2 . _simDuration tDuration <- sampleNDiffTime dur - + let MkFixed us = realToFrac d' :: Micro threadDelay $ fromInteger us start <- liftIO getCurrentTime @@ -268,7 +268,7 @@ runSimulation' LoadSheetSubmission = do -- Just formData <- return . getFormData FIDsubmission $ resp ^. responseBody -- Just addButtonData <- return . flip (runFormScraper FIDsubmission) (resp ^. responseBody) $ do -- let btnSel = "button" Scalpel.@: [Scalpel.hasClass "btn-mass-input-add"] - + -- name <- Scalpel.attr "name" btnSel -- value <- Scalpel.attr "value" btnSel -- guard $ value == "add__0__0" @@ -305,7 +305,7 @@ runSimulation' LoadSheetSubmission = do procEnd <- join $ asks runtime print ("proc", procEnd - procStart) - + resp3 <- liftIO . httpRetry $ Session.post session (uriToString id formURI mempty) subData void . evaluate $! resp3 where @@ -328,11 +328,11 @@ runSimulation' LoadSheetSubmission = do -> m () logRetry shouldRetry err status = liftIO . putStrLn . pack $ Retry.defaultLogMsg shouldRetry err status - + -- runSimulation' other = terror $ "Not implemented: " <> tshow other runFormScraper :: FormIdentifier -> Scalpel.Scraper Lazy.ByteString a -> Lazy.ByteString -> Maybe a -runFormScraper fid innerS = fmap join . flip Scalpel.scrapeStringLike $ +runFormScraper fid innerS = fmap join . flip Scalpel.scrapeStringLike $ fmap listToMaybe . Scalpel.chroots "form" $ do fid' <- Scalpel.attr "value" $ "input" Scalpel.@: ["name" Scalpel.@= "form-identifier"] guard $ fid' == encodeUtf8 (fromStrict $ toPathPiece fid) @@ -341,11 +341,11 @@ runFormScraper fid innerS = fmap join . flip Scalpel.scrapeStringLike $ getFormData :: FormIdentifier -> Lazy.ByteString -> Maybe [FormParam] getFormData = flip runFormScraper $ - Scalpel.chroots ("input") $ do + Scalpel.chroots "input" $ do name <- Scalpel.attr "name" Scalpel.anySelector value <- Scalpel.attr "value" Scalpel.anySelector <|> pure "" return $ toStrict name := value - + newLoadSession :: ReaderT SimulationContext IO Session newLoadSession = do @@ -354,7 +354,7 @@ newLoadSession = do let withToken = case loadToken of Nothing -> id Just (Jwt bs) -> (:) (hAuthorization, "Bearer " <> bs) . filter ((/= hAuthorization) . fst) - + liftIO . Session.newSessionControl (Just mempty) $ tlsManagerSettings { managerModifyRequest = \req -> return $ req { requestHeaders = withToken $ requestHeaders req } diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index adbc5df67..bab28d39b 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -192,7 +192,6 @@ import Network.Mail.Mime.Instances as Import import Yesod.Core.Instances as Import () import Data.Aeson.Types.Instances as Import () import Database.Esqueleto.Instances as Import () -import Database.Esqueleto.PostgreSQL.JSON as Import (JSONB(..), unJSONB) import Numeric.Natural.Instances as Import () import Text.Blaze.Instances as Import () import Jose.Jwt.Instances as Import () @@ -272,8 +271,3 @@ import Control.Monad.Trans.RWS (RWST) type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m type WeekDay = DayOfWeek - --- TODO: maybe move elsewhere -deriving newtype instance NFData a => NFData (JSONB a) -deriving newtype instance Semigroup a => Semigroup (JSONB a) -deriving newtype instance Monoid a => Monoid (JSONB a) diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index df9bc1a79..d98422be7 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-orphans #-} + {-| Module: Model.Types.Common Description: Common types used by most @Model.Types.*@-Modules @@ -10,12 +12,13 @@ Types used by multiple other @Model.Types.*@-Modules -} module Model.Types.Common ( module Model.Types.Common + , module JSON ) where import Import.NoModel import qualified Yesod.Auth.Util.PasswordStore as PWStore - +import Database.Esqueleto.PostgreSQL.JSON as JSON (JSONB(..), JSONAccessor(..), unJSONB) type Count = Sum Integer type Points = Centi @@ -68,3 +71,7 @@ type SessionFileReference = Digest SHA3_256 type QualificationName = CI Text type QualificationShorthand = CI Text + +deriving newtype instance NFData a => NFData (JSONB a) +deriving newtype instance Semigroup a => Semigroup (JSONB a) +deriving newtype instance Monoid a => Monoid (JSONB a) diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 43c24a761..6a3457783 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -29,6 +29,7 @@ import Data.Time.Calendar.WeekDate -- import qualified Text.ParserCombinators.Parsec.Number as ParseNum (nat) import Database.Persist.Sql +import Database.Esqueleto.PostgreSQL.JSON (JSONB(..)) import Web.HttpApiData From 2385d989a8cc79d9c0dd0d45578dbf6a769ccfe2 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 17 Sep 2024 12:58:13 +0200 Subject: [PATCH 018/187] fix(build) --- src/Handler/PrintCenter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 167704c4d..c139a2b00 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -528,7 +528,7 @@ getPrintLogR = do dbtColonnade = dbColonnade $ mconcat [ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t , sortable (Just "status") (textCell "Status" ) $ tCell (cellMaybe iconBoolCell . transactionInterfaceSuccess) - , sortable (Just "interface") (i18nCell MsgInterfaceName ) $ tCell ( tellCell . transactionInterfaceName) + , sortable (Just "interface") (i18nCell MsgInterfaceName ) $ tCell ( textCell . transactionInterfaceName) , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ tCell ( textCell . transactionInterfaceSubtype) , sortable (Just "info") (i18nCell MsgSystemMessageContent ) $ tCellErr ( textCell . transactionInterfaceInfo) ] From 26ea39dc679b66807d4eac1c1c6e860d84bc33f4 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 17 Sep 2024 17:58:52 +0200 Subject: [PATCH 019/187] fix(lpr): print log sorting works now --- src/Handler/PrintCenter.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index c139a2b00..ce701debc 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -534,10 +534,10 @@ getPrintLogR = do ] dbtSorting = mconcat [ singletonMap "time" $ SortColumn (E.^. TransactionLogTime) - , singletonMap "status" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-success") - , singletonMap "interface" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-name" ) - , singletonMap "subtype" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-subtype") - , singletonMap "info" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-info" ) + , singletonMap "status" $ SortColumn (\r -> r E.^. TransactionLogInfo E.->>. "interface-success") + , singletonMap "interface" $ SortColumn (\r -> r E.^. TransactionLogInfo E.->>. "interface-name" ) + , singletonMap "subtype" $ SortColumn (\r -> r E.^. TransactionLogInfo E.->>. "interface-subtype") + , singletonMap "info" $ SortColumn (\r -> r E.^. TransactionLogInfo E.->>. "interface-info" ) ] dbtFilter = mempty dbtFilterUI = mempty From 5c70b1099c12b3c9f08cabb187720e4caa389c13 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 17 Sep 2024 17:59:58 +0200 Subject: [PATCH 020/187] fix(firm): filtering by active supervisor working --- .../utils/table_column/de-de-formal.msg | 1 + messages/uniworx/utils/table_column/en-eu.msg | 1 + src/Handler/Firm.hs | 69 +++++++++++-------- 3 files changed, 41 insertions(+), 30 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 5e658cb43..a4d2818fa 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -99,6 +99,7 @@ TableCompanyNrRerouteActive: Aktive Umleitungen TableRerouteActive: Umleitung TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige TableSupervisor: Ansprechpartner +TableSupervisorActive: Aktiver Ansprechpartner TableSupervisee: Ansprechpartner für TableReason: Begründung TableCreationTime: Erstellungszeit diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 97d3ba9cc..d213ba05f 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -99,6 +99,7 @@ TableCompanyNrRerouteActive: Active reroutes TableRerouteActive: Reroute TableCompanyPostalPreference: Default notification preference TableSupervisor: Supervisor +TableSupervisorActive: Active supervisor TableSupervisee: Supervisor for TableReason: Reason TableCreationTime: Creation diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 4acf5139e..fa5e52d8f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -440,7 +440,7 @@ mkFirmAllTable isAdmin uid = do -- , cmpy & firmCountActiveReroutes' ) dbtRowKey = (E.^. CompanyId) - dbtProj = dbtProjFilteredPostId + dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat [ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> @@ -569,34 +569,34 @@ mkFirmAllTable isAdmin uid = do -- )) -- ) -- ) - , ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr -> - case criterion of - Nothing -> return True :: DB Bool - (Just (crit::Text)) -> do - critFirms <- memcachedBy (Just . Right $ 3 * diffMinute) ("SVR:"<>crit) $ fmap (Set.fromList . fmap E.unValue) $ E.select $ E.distinct $ do - (usr :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @Company - `E.on` (\(usr :& cmp) -> E.exists (do - usrCmp <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser - E.&&. usrCmp E.^. UserCompanySupervisor - E.&&. usrCmp E.^. UserCompanyCompany E.==. cmp E.^. CompanyId - ) E.||. E.exists (do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor - E.&&. E.exists (do - usrSub <- E.from $ E.table @UserCompany - E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser - E.&&. usrSub E.^. UserCompanyCompany E.==. cmp E.^. CompanyId - ) - )) - E.where_ $ (usr E.^. UserDisplayName `E.hasInfix` E.val crit ) - E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit)) - E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit ) - -- E.orderBy [E.asc $ cmp E.^. CompanyId] - return $ cmp E.^. CompanyId - let cid = dbr ^. resultAllCompanyEntity . _entityKey - return $ Set.member cid critFirms - ) + -- , ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- did not work as intended + -- case criterion of + -- Nothing -> return True :: DB Bool + -- (Just (crit::Text)) -> do + -- critFirms <- memcachedBy (Just . Right $ 3 * diffMinute) ("SVR:" <> crit) $ fmap (Set.fromList . fmap E.unValue) $ E.select $ E.distinct $ do + -- (usr :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @Company + -- `E.on` (\(usr :& cmp) -> E.exists (do + -- usrCmp <- E.from $ E.table @UserCompany + -- E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser + -- E.&&. usrCmp E.^. UserCompanySupervisor + -- E.&&. usrCmp E.^. UserCompanyCompany E.==. cmp E.^. CompanyId + -- ) E.||. E.exists (do + -- usrSpr <- E.from $ E.table @UserSupervisor + -- E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor + -- E.&&. E.exists (do + -- usrSub <- E.from $ E.table @UserCompany + -- E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + -- E.&&. usrSub E.^. UserCompanyCompany E.==. cmp E.^. CompanyId + -- ) + -- )) + -- E.where_ $ (usr E.^. UserDisplayName `E.hasInfix` E.val crit ) + -- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit)) + -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit ) + -- -- E.orderBy [E.asc $ cmp E.^. CompanyId] + -- return $ cmp E.^. CompanyId + -- let cid = dbr ^. resultAllCompanyEntity . _entityKey + -- return $ Set.member cid critFirms + -- ) -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow -- (usr :& usrCmp) <- E.from $ E.table @User -- `E.leftJoin` E.table @UserCompany @@ -612,6 +612,15 @@ mkFirmAllTable isAdmin uid = do -- ) -- ) -- ) + , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + (usr :& _usrSpr :& usrCmp) <- E.from $ E.table @User + `E.innerJoin` E.table @UserSupervisor `E.on` (\(usr :& usrSpr ) -> usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor) + `E.innerJoin` E.table @UserCompany `E.on` (\(_ :& usrSpr :& usrCmp) -> usrCmp E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser) + 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.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + ) , ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany @@ -669,7 +678,7 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "is-associate") mPrev $ aopt textField (fslI MsgTableCompanyUser) -- , prismAForm (singletonFilter "is-supervisor0") mPrev $ aopt textField (fslI MsgTableSupervisor) - , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisorActive) , prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault) , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern & setTooltip MsgFilterFirmExternTooltip) From cac0a47d01e6f7ff0213f9dd8f747071ae6331ac Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 18 Sep 2024 18:03:49 +0200 Subject: [PATCH 021/187] refactor(daily): factor our tutorial selection function --- src/Handler/School/DayTasks.hs | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index db154a960..83b1f4f88 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -22,7 +22,7 @@ import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text -- import Database.Persist.Sql (updateWhereCount) --- import Database.Esqueleto.Experimental ((:&)(..)) +import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E @@ -51,7 +51,19 @@ occurrenceDayValue d = Aeson.object ] ] ] -- TODO: ensure that an appropriate GIN index for the jsonb column is set - +getDayTutorials :: SchoolId -> Day -> DB [TutorialId] +getDayTutorials ssh d = E.unValue <<$>> E.select (do +-- getDayTutorials :: SchoolId -> Day -> DB [E.Value TutorialId] +-- getDayTutorials ssh d = E.select (do + (trm :& crs :& tut) <- E.from $ E.table @Term + `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) + `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) + E.where_ $ E.between (E.val d) (trm E.^. TermStart, trm E.^. TermEnd) + E.&&. crs E.^. CourseSchool E.==. E.val ssh + E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue d)) + return $ tut E.^. TutorialId + ) + -- CONTINUE HERE: deal with regular schedules and exceptions, filter in Haskell-Land and use memcaching for the result type DailyTableExpr = ( E.SqlExpr (Entity Course) @@ -100,19 +112,14 @@ instance HasUser DailyTableData where mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do + tuts <- getDayTutorials ssh nd let dbtSQLQuery :: DailyTableExpr -> DailyTableOutput dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser - E.where_ $ crs E.^. CourseSchool E.==. E.val ssh - E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue nd)) - E.&&. E.exists (do - trm <- E.from $ E.table @Term - E.where_ $ trm E.^. TermId E.==. crs E.^. CourseTerm - E.&&. E.between (E.val nd) (trm E.^. TermStart, trm E.^. TermEnd) - ) + E.where_ $ tut E.^. TutorialId `E.in_` E.valList tuts return (crs, tut, tpu, usr, selectCompanyUserPrime usr) dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtProj = dbtProjId From 74c330bd243b429ff8fe905a987dacf875426d16 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 23 Sep 2024 17:09:47 +0200 Subject: [PATCH 022/187] chore(memcached): add key classes for easy invalidation --- src/Handler/Course/Edit.hs | 1 + src/Handler/School/DayTasks.hs | 40 +++++++++++++--- src/Handler/Term.hs | 13 +++--- src/Handler/Tutorial/Edit.hs | 1 + src/Handler/Utils/Delete.hs | 2 + src/Handler/Utils/Memcached.hs | 79 +++++++++++++++++++++++++------- src/Handler/Utils/Occurrences.hs | 13 ++++-- src/Utils.hs | 2 +- 8 files changed, 117 insertions(+), 34 deletions(-) diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 138fd2c6c..1e06c919b 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -452,6 +452,7 @@ courseEditHandler miButtonAction mbCourseForm = do sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites void $ upsertCourseQualifications aid cid $ cfQualis res insert_ $ CourseEdit aid now cid + memcachedFlushClass MemcachedKeyClassTutorialOccurrences memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId) addMessageI Success $ MsgCourseEditOk tid ssh csh return True diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 83b1f4f88..0dd956333 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -15,8 +15,9 @@ import Import import Handler.Utils import Handler.Utils.Company +import Handler.Utils.Occurrences --- import qualified Data.Set as Set +import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text @@ -51,10 +52,9 @@ occurrenceDayValue d = Aeson.object ] ] ] -- TODO: ensure that an appropriate GIN index for the jsonb column is set +{- More efficient DB-only version, but ignores regular schedules getDayTutorials :: SchoolId -> Day -> DB [TutorialId] getDayTutorials ssh d = E.unValue <<$>> E.select (do --- getDayTutorials :: SchoolId -> Day -> DB [E.Value TutorialId] --- getDayTutorials ssh d = E.select (do (trm :& crs :& tut) <- E.from $ E.table @Term `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) @@ -63,7 +63,35 @@ getDayTutorials ssh d = E.unValue <<$>> E.select (do E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue d)) return $ tut E.^. TutorialId ) - -- CONTINUE HERE: deal with regular schedules and exceptions, filter in Haskell-Land and use memcaching for the result +-} + +-- Datatype to be used for memcaching occurrences +data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day) + deriving (Eq, Ord, Read, Show, Generic) + deriving anyclass (Hashable, Binary) + +getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] +getDayTutorials ssh dlimit@(dstart, dend ) + | dstart > dend = return mempty + | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do + candidates <- E.select $ do + (trm :& crs :& tut) <- E.from $ E.table @Term + `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) + `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) + E.where_ $ crs E.^. CourseSchool E.==. E.val ssh + E.&&. trm E.^. TermStart E.<=. E.val dend + E.&&. trm E.^. TermEnd E.>=. E.val dstart + return (trm, tut) + $logErrorS "memcached" $ "***DEBUG*****CACHE*****" <> tshow (ssh,dlimit) <> "***************" -- DEBUG ONLY + return $ mapMaybe checkCandidate candidates + where + period = Set.fromAscList [dstart..dend] + + checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}) + | not $ Set.null $ Set.intersection period $ occurrencesCompute trm occ + = Just tutId + | otherwise + = Nothing type DailyTableExpr = ( E.SqlExpr (Entity Course) @@ -112,7 +140,7 @@ instance HasUser DailyTableData where mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do - tuts <- getDayTutorials ssh nd + tuts <- getDayTutorials ssh (nd,nd) let dbtSQLQuery :: DailyTableExpr -> DailyTableOutput dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do @@ -133,7 +161,7 @@ mkDailyTable isAdmin ssh nd = do in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid - , colUserNameModalHdr MsgTableCourseMembers ForProfileDataR + , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin ] dbtSorting = Map.fromList diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 345f0d882..7273e8757 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -29,7 +29,7 @@ import qualified Control.Monad.State.Class as State validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator TermForm m () validateTerm = do - TermForm{..} <- State.get + TermForm{..} <- State.get guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart @@ -87,7 +87,7 @@ getTermShowR = do $of Left singleHoliday ^{formatTimeW SelFormatDate singleHoliday} $of Right (startD, endD) - ^{formatTimeRangeW SelFormatDate startD (Just endD)} + ^{formatTimeRangeW SelFormatDate startD (Just endD)} |] ] dbtSorting = Map.fromList @@ -150,11 +150,11 @@ postTermEditR = do Set.unions $ bankHolidaysAreaSet Fraport <$> [getYear tStart..getYear tEnd] in mempty { tftName = Just ntid - , tftStart = Just tStart - , tftEnd = Just tEnd + , tftStart = Just tStart + , tftEnd = Just tEnd , tftLectureStart = Just tLecStart , tftLectureEnd = Just tLecEnd - , tftHolidays = Just tHolys + , tftHolidays = Just tHolys } termEditHandler Nothing template @@ -201,6 +201,7 @@ termEditHandler mtid template = do , termActiveFor = tafFor } lift . audit $ TransactionTermEdit tid + memcachedFlushClass MemcachedKeyClassTutorialOccurrences addMessageI Success $ MsgTermEdited tid redirect TermShowR FormMissing -> return () @@ -332,7 +333,7 @@ newTermForm mtid template = validateForm validateTerm $ \html -> do (fromRes, fromView) <- mpreq utcTimeField ("" & addName (mkUnique "from")) Nothing (toRes, toView) <- mopt utcTimeField ("" & addName (mkUnique "to")) Nothing (forRes, forView) <- mopt (checkMap (first $ const MsgTermFormActiveUserNotFound) Right $ userField False Nothing) ("" & addName (mkUnique "for") & addPlaceholder (mr MsgTermActiveForPlaceholder)) Nothing - + let res = TermActiveForm <$> fromRes <*> toRes <*> forRes res' = res <&> \newDat oldDat -> if | newDat `elem` oldDat diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs index ee65bd4cc..c13c88df0 100644 --- a/src/Handler/Tutorial/Edit.hs +++ b/src/Handler/Tutorial/Edit.hs @@ -88,6 +88,7 @@ postTEditR tid ssh csh tutn = do case insertRes of Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName Nothing -> do + memcachedFlushClass MemcachedKeyClassTutorialOccurrences addMessageI Success $ MsgTutorialEdited tfName redirect $ CourseR tid ssh csh CTutorialListR diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index dbd062bbb..418972395 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -21,6 +21,7 @@ module Handler.Utils.Delete import Import import Handler.Utils.Form +import Handler.Utils.Memcached import qualified Data.Text as Text import qualified Data.Set as Set @@ -113,6 +114,7 @@ deleteR' DeleteRoute{..} = do True -> do runDBJobs $ do forM_ drRecords $ \k -> drDelete k $ delete k + memcachedFlushClass MemcachedKeyClassTutorialOccurrences addMessageI Success drSuccessMessage redirect drSuccess False -> diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 091e88418..38f00d882 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -7,9 +7,10 @@ module Handler.Utils.Memcached ( memcachedAvailable , memcached, memcachedBy + , memcachedByClass, memcachedFlushClass, MemcachedKeyClass(..) , memcachedHere, memcachedByHere , memcachedSet, memcachedGet - , memcachedInvalidate, memcachedByInvalidate + , memcachedInvalidate, memcachedByInvalidate, memcachedFlushAll , manageMemcachedLocalInvalidations , memcachedByGet, memcachedBySet , memcachedTimeout, memcachedTimeoutBy @@ -40,6 +41,8 @@ import qualified Data.Binary.Get as Binary import Crypto.Hash.Algorithms (SHAKE256) +import qualified Data.Set as Set + import qualified Data.ByteArray as BA import qualified Data.ByteString.Base64 as Base64 @@ -204,7 +207,7 @@ memcachedByGet (Binary.encode -> k) = runMaybeT $ arc <|> memcache decrypted <- hoistMaybe $ AEAD.aeadOpen memcachedKey mNonce mCiphertext aad $logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration" - + let withCache = case localARC of Just AppMemcachedLocal{..} -> cachedARC memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) Nothing -> fmap (view _1) . ($ Nothing) @@ -231,7 +234,16 @@ memcachedBySet :: forall a k m. , Binary k ) => Maybe Expiry -> k -> a -> m () -memcachedBySet mExp (Binary.encode -> k) v = do +memcachedBySet = ((void .) .) . memcachedBySet' + +memcachedBySet' :: forall a k m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadThrow m + , Typeable a, Binary a, NFData a + , Binary k + ) + => Maybe Expiry -> k -> a -> m (Maybe ByteString) +memcachedBySet' mExp (Binary.encode -> k) v = do mExp' <- for mExp $ \exp -> maybe (throwM $ MemcachedInvalidExpiry exp) return $ exp ^? _MemcachedExpiry let decrypted = toStrict $ Binary.encode v @@ -240,13 +252,14 @@ memcachedBySet mExp (Binary.encode -> k) v = do Right diff -> liftIO $ (+ realToFrac diff) <$> getPOSIXTime mConn <- getsYesod appMemcached - for_ mConn $ \AppMemcached{..} -> do + bsKey <- for mConn $ \AppMemcached{..} -> do mNonce <- liftIO AEAD.newNonce let cKey = toMemcachedKey memcachedKey (Proxy @a) k aad = memcachedAAD cKey mExpiry mCiphertext = AEAD.aead memcachedKey mNonce decrypted aad liftIO . handle (\(_ :: Memcached.MemcachedException) -> return ()) $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) memcachedConn $logDebugS "memcached" $ "Cache store: " <> tshow mExpiry + return cKey mLocal <- getsYesod appMemcachedLocal for_ mLocal $ \AppMemcachedLocal{..} -> do @@ -257,6 +270,7 @@ memcachedBySet mExp (Binary.encode -> k) v = do where mLocalInvalidateType = typeRepFingerprint . typeRep $ Proxy @a mLocalInvalidateKey = k $logDebugS "memcached" $ "To invalidate remotely: " <> tshow inv + return bsKey memcachedByInvalidate :: forall a k m p. ( MonadHandler m, HandlerSite m ~ UniWorX @@ -293,7 +307,7 @@ instance Binary MemcachedLocalInvalidateMsg where Binary.putWord64le w1 Binary.putWord64le w2 Binary.putLazyByteString mLocalInvalidateKey - + manageMemcachedLocalInvalidations :: ( MonadUnliftIO m , MonadLogger m ) @@ -318,7 +332,7 @@ manageMemcachedLocalInvalidations localARC iQueue = PostgresqlChannelManager } -newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a } +newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a } deriving newtype (Eq, Ord, Show, Binary) instance NFData a => NFData (MemcachedUnkeyed a) where rnf = rnf . unMemcachedUnkeyed @@ -343,14 +357,12 @@ memcachedInvalidate :: forall (a :: Type) m p. => p a -> m () memcachedInvalidate _ = memcachedByInvalidate () $ Proxy @(MemcachedUnkeyed a) +memcachedFlushAll :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () +memcachedFlushAll = getsYesod appMemcached >>= flip whenIsJust (liftIO . Memcached.flushAll . memcachedConn) memcachedWith :: Monad m => (m (Maybe b), a -> m b) -> m a -> m b -memcachedWith (doGet, doSet) act = do - pRes <- doGet - maybe id (const . return) pRes $ do - res <- act - doSet res +memcachedWith (doGet, doSet) act = maybeM (act >>= doSet) pure doGet memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m @@ -369,7 +381,42 @@ memcachedBy :: forall a m k. memcachedBy mExp k = memcachedWith (memcachedByGet k, \x -> x <$ memcachedBySet mExp k x) -newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a } +data MemcachedKeyClass + = MemcachedKeyClassTutorialOccurrences + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, NFData) + deriving anyclass (Hashable, Binary, Universe, Finite) + +newtype MemcachedKeyClassStore = MemcachedKeyClassStore{ unMemcachedKeyClassStore :: Set ByteString } + deriving newtype (Eq, Ord, Semigroup, Monoid, Show, Binary, NFData) +-- instance NFData MemcachedKeyClassStore where +-- rnf MemcachedKeyClassStore{..} = rnf unMemcachedKeyClassStore + +memcachedByClass :: forall a m k. + ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadThrow m + , Typeable a, Binary a, NFData a + , Binary k + ) + => MemcachedKeyClass -> Maybe Expiry -> k -> m a -> m a +memcachedByClass mkc mExp k = memcachedWith (memcachedByGet k, setAndAddClass) + where + setAndAddClass v = do + mbKey <- memcachedBySet' mExp k v + whenIsJust mbKey $ \vKey -> do + cl <- maybeMonoid <$> memcachedByGet mkc + memcachedBySet Nothing mkc $ MemcachedKeyClassStore $ Set.insert vKey $ unMemcachedKeyClassStore cl + -- memcachedBySet Nothing mkc $ cl <> MemcachedKeyClassStore $ Set.singleton vKey + return v + +memcachedFlushClass :: (MonadHandler m, HandlerSite m ~ UniWorX) => MemcachedKeyClass -> m () +memcachedFlushClass mkc = maybeT_ $ do + AppMemcached{..} <- MaybeT $ getsYesod appMemcached + cl <- MaybeT $ memcachedByGet mkc + hoist liftIO $ forM_ (unMemcachedKeyClassStore cl) $ + catchIfMaybeT Memcached.isKeyNotFound . flip Memcached.delete memcachedConn + lift $ memcachedByInvalidate mkc (Proxy @MemcachedKeyClassStore) + +newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a } deriving newtype (Eq, Ord, Show, Binary) instance NFData a => NFData (MemcachedUnkeyedLoc a) where rnf MemcachedUnkeyedLoc{..} = rnf unMemcachedUnkeyedLoc @@ -379,7 +426,7 @@ memcachedHere = do loc <- location [e| \mExp -> fmap unMemcachedUnkeyedLoc . memcachedBy mExp loc . fmap MemcachedUnkeyedLoc |] -newtype MemcachedKeyedLoc a = MemcachedKeyedLoc { unMemcachedKeyedLoc :: a } +newtype MemcachedKeyedLoc a = MemcachedKeyedLoc { unMemcachedKeyedLoc :: a } deriving newtype (Eq, Ord, Show, Binary) instance NFData a => NFData (MemcachedKeyedLoc a) where rnf MemcachedKeyedLoc{..} = rnf unMemcachedKeyedLoc @@ -563,7 +610,7 @@ memcacheAuth' :: forall a m k. -> m a -> m a memcacheAuth' exp k = memcacheAuth k . (<* tell (Just $ Min exp)) . lift - + memcacheAuthMax :: forall m k a. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m @@ -585,7 +632,7 @@ memcacheAuthHere' :: Q Exp memcacheAuthHere' = do loc <- location [e| \exp k -> withMemcachedKeyedLoc (memcacheAuth' exp (loc, k)) |] - + memcacheAuthHereMax :: Q Exp memcacheAuthHereMax = do loc <- location diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 93642d524..f5fc0b9fa 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -4,6 +4,7 @@ module Handler.Utils.Occurrences ( occurrencesWidget + , occurrencesCompute , occurrencesBounds , occurrencesAddBusinessDays ) where @@ -35,12 +36,10 @@ occurrencesWidget (normalizeOccurrences . unJSONB -> Occurrences{..}) = do $(widgetFile "widgets/occurrence/cell/except-no-occur") $(widgetFile "widgets/occurrence/cell") --- | Get bounds for an Occurrences -occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) -occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays) +-- | Get all occurrences during a term, excluding term holidays from the regular schedule, but not from exceptins +occurrencesCompute :: Term -> Occurrences -> Set Day +occurrencesCompute Term{..} Occurrences{..} = ((scdDays \\ Set.fromList termHolidays) <> plsDays) \\ excDays where - occDays = (scdDays <> plsDays) \\ excDays -- (excDays <> termHolidays term) -- TODO: should holidays be exluded here? Probably not, as they can be added as exceptions already - scdDays = Set.foldr getOccDays mempty occurrencesScheduled (plsDays,excDays) = Set.foldr getExcDays mempty occurrencesExceptions @@ -51,6 +50,10 @@ occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupM getOccDays :: OccurrenceSchedule -> Set Day -> Set Day getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday +-- | Get bounds for an Occurrences +occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) +occurrencesBounds = (liftM2 (,) Set.lookupMin Set.lookupMax .) . occurrencesCompute + occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions where diff --git a/src/Utils.hs b/src/Utils.hs index 617293cae..5c68ba25a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -655,7 +655,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 +-- fold would also do, but is more risky if the Foldable isn't Maybe maybeMonoid :: Monoid m => Maybe m -> m -- ^ Identify `Nothing` with `mempty` maybeMonoid = fromMaybe mempty From e757209b802a084d4d56f766a3fa756ac5a80cfa Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 23 Sep 2024 18:52:26 +0200 Subject: [PATCH 023/187] refactor(memcached): remove ARC cache entirely NOTE: this was a crude surgery, removing everything ARC related; some dead code artifacts may have remained. Especially check PrewarmCacheConf Reason for removall: adding `memcachedInvalidateClass` was difficult to implement with ARC active; ARC was known to be problematic; removal was easier (see #2 2024-09-23) --- config/settings.yml | 3 - src/Application.hs | 20 +- src/Foundation/Authorization.hs | 6 +- src/Foundation/Type.hs | 16 +- src/Handler/Utils.hs | 4 +- src/Handler/Utils/Avs.hs | 2 +- src/Handler/Utils/Files.hs | 71 +++---- src/Handler/Utils/Memcached.hs | 162 ++++++--------- src/Settings.hs | 4 +- src/Utils.hs | 1 - src/Utils/ARC.hs | 344 -------------------------------- src/Utils/LRU.hs | 32 +-- src/Utils/Metrics.hs | 61 ++---- 13 files changed, 122 insertions(+), 604 deletions(-) delete mode 100644 src/Utils/ARC.hs diff --git a/config/settings.yml b/config/settings.yml index 472d86578..e5ae9c03f 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -206,9 +206,6 @@ memcached: timeout: "_env:MEMCACHED_TIMEOUT:20" expiration: "_env:MEMCACHED_EXPIRATION:300" memcache-auth: true -memcached-local: - maximum-ghost: 512 - maximum-weight: 104857600 # 100MiB upload-cache: host: "_env:UPLOAD_S3_HOST:localhost" # should be optional, but all file transfers will be empty without an S3 cache diff --git a/src/Application.hs b/src/Application.hs index ac5854c02..58156b47a 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -119,9 +119,6 @@ import qualified Data.IntervalMap.Strict as IntervalMap import qualified Utils.Pool as Custom -import Utils.Postgresql -import Handler.Utils.Memcached (manageMemcachedLocalInvalidations) - import qualified System.Clock as Clock import Utils.Avs (mkAvsQuery) @@ -219,10 +216,6 @@ makeFoundation appSettings''@AppSettings{..} = do appJobState <- liftIO newEmptyTMVarIO appHealthReport <- liftIO $ newTVarIO Set.empty - appFileSourceARC <- for appFileSourceARCConf $ \ARCConf{..} -> do - ah <- initARCHandle arccMaximumGhost arccMaximumWeight - void . Prometheus.register $ arcMetrics ARCFileSource ah - return ah appFileSourcePrewarm <- for appFileSourcePrewarmConf $ \PrewarmCacheConf{..} -> do lh <- initLRUHandle precMaximumWeight void . Prometheus.register $ lruMetrics LRUFileSourcePrewarm lh @@ -239,7 +232,7 @@ makeFoundation appSettings''@AppSettings{..} = do -- from there, and then create the real foundation. let mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _ - mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..} + mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..} tempFoundation = mkFoundation (error "appSettings' forced in tempFoundation") (error "connPool forced in tempFoundation") @@ -252,7 +245,6 @@ makeFoundation appSettings''@AppSettings{..} = do (error "JSONWebKeySet forced in tempFoundation") (error "ClusterID forced in tempFoundation") (error "memcached forced in tempFoundation") - (error "memcachedLocal forced in tempFoundation") (error "MinioConn forced in tempFoundation") (error "VerpSecret forced in tempFoundation") (error "AuthKey forced in tempFoundation") @@ -337,12 +329,6 @@ makeFoundation appSettings''@AppSettings{..} = do $logWarnS "setup" "Clearing memcached" liftIO $ Memcached.flushAll memcachedConn return AppMemcached{..} - appMemcachedLocal <- for appMemcachedLocalConf $ \ARCConf{..} -> do - memcachedLocalARC <- initARCHandle arccMaximumGhost arccMaximumWeight - void . Prometheus.register $ arcMetrics ARCMemcachedLocal memcachedLocalARC - memcachedLocalInvalidationQueue <- newTVarIO mempty - memcachedLocalHandleInvalidations <- allocateLinkedAsync . managePostgresqlChannel appDatabaseConf ChannelMemcachedLocalInvalidation $ manageMemcachedLocalInvalidations memcachedLocalARC memcachedLocalInvalidationQueue - return AppMemcachedLocal{..} appSessionStore <- mkSessionStore appSettings'' sqlPool `customRunSqlPool` sqlPool @@ -380,7 +366,7 @@ makeFoundation appSettings''@AppSettings{..} = do $logDebugS "Runtime configuration" $ tshowCrop appSettings' - let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery + let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery -- Return the foundation $logInfoS "setup" "*** DONE ***" diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 7e0812297..93b15fd70 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -313,7 +313,8 @@ isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM dnf <- throwLeft $ routeAuthTags currentRoute let eval :: forall m''. MonadAP m'' => AuthTagsEval m'' - eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite' + -- eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite' + eval dnf' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') in guardAuthResult <=< evalWriterT $ eval dnf mAuthId currentRoute isWrite return False @@ -368,7 +369,8 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar eval :: forall m'. MonadAP m' => AuthTagsEval m' - eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite'' + -- eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite'' + eval dnf' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') bearerAuthority' <- hoist apRunDB $ do bearerAuthority' <- flip foldMapM bearerAuthority $ \case diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 1084d181d..9dbc9de50 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -11,8 +11,6 @@ module Foundation.Type , _SessionStorageMemcachedSql, _SessionStorageAcid , AppMemcached(..) , _memcachedKey, _memcachedConn - , AppMemcachedLocal(..) - , _memcachedLocalARC , SMTPPool , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache, _appAvsQuery , DB, DBRead, Form, MsgRenderer, MailM, DBFile @@ -38,9 +36,6 @@ import qualified Utils.Pool as Custom import Utils.Metrics (DBConnUseState) -import qualified Data.ByteString.Lazy as Lazy -import Data.Time.Clock.POSIX (POSIXTime) -import GHC.Fingerprint (Fingerprint) import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey) import Utils.Avs (AvsQuery()) @@ -62,13 +57,6 @@ data AppMemcached = AppMemcached makeLenses_ ''AppMemcached -data AppMemcachedLocal = AppMemcachedLocal - { memcachedLocalARC :: ARCHandle (Fingerprint, Lazy.ByteString) Int (NFDynamic, Maybe POSIXTime) - , memcachedLocalHandleInvalidations :: Async () - , memcachedLocalInvalidationQueue :: TVar (Seq (Fingerprint, Lazy.ByteString)) - } deriving (Generic) - -makeLenses_ ''AppMemcachedLocal -- | The foundation datatype for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -93,11 +81,9 @@ data UniWorX = UniWorX , appJSONWebKeySet :: Jose.JwkSet , appHealthReport :: TVar (Set (UTCTime, HealthReport)) , appMemcached :: Maybe AppMemcached - , appMemcachedLocal :: Maybe AppMemcachedLocal , appUploadCache :: Maybe MinioConn , appVerpSecret :: VerpSecret , appAuthKey :: Auth.Key - , appFileSourceARC :: Maybe (ARCHandle (FileContentChunkReference, (Int, Int)) Int ByteString) , appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString) , appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference)) , appPersonalisedSheetFilesSeedKey :: PersonalisedSheetFilesSeedKey diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 4abcd0ce2..fd8f3d6c9 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -26,7 +26,7 @@ import Handler.Utils.I18n as Handler.Utils import Handler.Utils.Widgets as Handler.Utils import Handler.Utils.Database as Handler.Utils import Handler.Utils.Occurrences as Handler.Utils -import Handler.Utils.Memcached as Handler.Utils hiding (manageMemcachedLocalInvalidations) +import Handler.Utils.Memcached as Handler.Utils import Handler.Utils.Files as Handler.Utils import Handler.Utils.Download as Handler.Utils import Handler.Utils.AuthorshipStatement as Handler.Utils diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index b8cb5a610..b331357e7 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -222,7 +222,7 @@ avsQueryNoCacheDefault qry = do qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery) throwLeftM $ qfun qry -avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q), NFData (SomeAvsResponse q) +avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q) , MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q) avsQueryCached qry = getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index cd91cc79f..b8a4a8cd2 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -18,8 +18,6 @@ import Foundation.Type import Foundation.DB import Utils.Metrics -import Data.Monoid (First(..)) - import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.List as C (unfoldM) @@ -32,7 +30,6 @@ import qualified Database.Esqueleto.Utils as E import System.FilePath (normalise, makeValid) import Data.List (dropWhileEnd) -import qualified Data.ByteString as ByteString data SourceFilesException @@ -44,58 +41,36 @@ data SourceFilesException makePrisms ''SourceFilesException -fileChunkARC :: ( MonadHandler m +fileChunk :: ( MonadHandler m , HandlerSite m ~ UniWorX ) - => Maybe Int - -> (FileContentChunkReference, (Int, Int)) + => (FileContentChunkReference, (Int, Int)) -> m (Maybe (ByteString, Maybe FileChunkStorage)) -> m (Maybe ByteString) -fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do +fileChunk k getChunkDB' = do prewarm <- getsYesod appFileSourcePrewarm - let getChunkDB = case prewarm of + -- NOTE: crude surgery happened here to remove ARC caching; useless artifacts may have remained + case prewarm of + Nothing -> do + chunk' <- getChunkDB' + for chunk' $ \(chunk, mStorage) -> chunk <$ do + $logDebugS "fileChunkARC" "No prewarm" + for_ mStorage $ \storage -> + let w = length chunk + in liftIO $ observeSourcedChunk storage w + Just lh -> do + chunkRes <- lookupLRUHandle lh k + case chunkRes of + Just (chunk, w) -> Just chunk <$ do + $logDebugS "fileChunkARC" "Prewarm hit" + liftIO $ observeSourcedChunk StoragePrewarm w Nothing -> do chunk' <- getChunkDB' for chunk' $ \(chunk, mStorage) -> chunk <$ do - $logDebugS "fileChunkARC" "No prewarm" + $logDebugS "fileChunkARC" "Prewarm miss" for_ mStorage $ \storage -> let w = length chunk - in liftIO $ observeSourcedChunk storage w - Just lh -> do - chunkRes <- lookupLRUHandle lh k - case chunkRes of - Just (chunk, w) -> Just chunk <$ do - $logDebugS "fileChunkARC" "Prewarm hit" - liftIO $ observeSourcedChunk StoragePrewarm w - Nothing -> do - chunk' <- getChunkDB' - for chunk' $ \(chunk, mStorage) -> chunk <$ do - $logDebugS "fileChunkARC" "Prewarm miss" - for_ mStorage $ \storage -> - let w = length chunk - in liftIO $ observeSourcedChunk storage w - - arc <- getsYesod appFileSourceARC - case arc of - Nothing -> getChunkDB - Just ah -> do - cachedARC' ah k $ \case - Nothing -> do - chunk' <- case assertM (> l) altSize of - -- This optimization works for the somewhat common case that cdc chunks are smaller than db chunks and start of the requested range is aligned with a db chunk boundary - Just altSize' - -> fmap getFirst . execWriterT . cachedARC' ah (ref, (s, altSize')) $ \x -> x <$ case x of - Nothing -> tellM $ First <$> getChunkDB - Just (v, _) -> tell . First . Just $ ByteString.take l v - Nothing -> getChunkDB - for chunk' $ \chunk -> do - let w = length chunk - $logDebugS "fileChunkARC" "ARC miss" - return (chunk, w) - Just x@(_, w) -> do - $logDebugS "fileChunkARC" "ARC hit" - liftIO $ Just x <$ observeSourcedChunk StorageARC w - + in liftIO $ observeSourcedChunk storage w sourceFileDB :: forall m. @@ -124,7 +99,7 @@ sourceFileChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlRe return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize) getChunkMinio = fmap (, StorageMinio) . catchIfMaybeT (is _SourceFilesContentUnavailable) . runConduit $ sourceMinio (Left chunkHash) (Just $ ByteRangeFromTo (fromIntegral $ pred start) (fromIntegral . pred $ pred start + dbChunksize)) .| C.fold in getChunkDB' <|> getChunkMinio - chunk <- fileChunkARC Nothing (chunkHash, (start, dbChunksize)) getChunkDB + chunk <- fileChunk (chunkHash, (start, dbChunksize)) getChunkDB case chunk of Just c | olength c <= 0 -> return Nothing Just c -> do @@ -256,7 +231,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectOne . E.from $ \fileContentChunk -> do E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize) - chunk <- fileChunkARC (Just $ fromIntegral dbChunksize) (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB + chunk <- fileChunk (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB case chunk of Nothing -> throwM SourceFilesContentUnavailable Just c -> do diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 38f00d882..2877bd9af 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -11,7 +11,6 @@ module Handler.Utils.Memcached , memcachedHere, memcachedByHere , memcachedSet, memcachedGet , memcachedInvalidate, memcachedByInvalidate, memcachedFlushAll - , manageMemcachedLocalInvalidations , memcachedByGet, memcachedBySet , memcachedTimeout, memcachedTimeoutBy , memcachedTimeoutHere, memcachedTimeoutByHere @@ -45,11 +44,9 @@ import qualified Data.Set as Set import qualified Data.ByteArray as BA -import qualified Data.ByteString.Base64 as Base64 - import Language.Haskell.TH hiding (Type) -import Data.Typeable (typeRep, typeRepFingerprint) +import Data.Typeable (typeRep) import Type.Reflection (typeOf, TypeRep) import qualified Type.Reflection as Refl (typeRep) import Data.Type.Equality (TestEquality(..)) @@ -72,10 +69,6 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString) import GHC.Fingerprint -import Utils.Postgresql - -import UnliftIO.Concurrent (threadDelay) - type Expiry = Either UTCTime DiffTime @@ -169,68 +162,49 @@ memcachedAAD cKey mExpiry = toStrict . Binary.runPut $ do memcachedByGet :: forall a k m. ( MonadHandler m, HandlerSite m ~ UniWorX - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Binary k ) => k -> m (Maybe a) -memcachedByGet (Binary.encode -> k) = runMaybeT $ arc <|> memcache - where - arc = do - AppMemcachedLocal{..} <- MaybeT $ getsYesod appMemcachedLocal - res <- hoistMaybe . preview (_1 . _NFDynamic) <=< hoistMaybe <=< cachedARC' memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) $ \mPrev -> do - prev@((_, prevExpiry), _) <- hoistMaybe mPrev - $logDebugS "memcached" "Cache hit (local ARC)" - lift . runMaybeT $ do -- To delete from ARC upon expiry - for_ prevExpiry $ \expiry -> do +memcachedByGet (Binary.encode -> k) = runMaybeT $ do + AppMemcached{..} <- MaybeT $ getsYesod appMemcached + let cKey = toMemcachedKey memcachedKey (Proxy @a) k + encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey memcachedConn + -- $logDebugS "memcached" "Cache hit" + + let withExp doExp = do + MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp + $logDebugS "memcached" "Decode valid" + for_ mExpiry $ \expiry -> do now <- liftIO getPOSIXTime - guard $ expiry > now - return prev - $logDebugS "memcached" "All valid (local ARC)" - return res - memcache = do - AppMemcached{..} <- MaybeT $ getsYesod appMemcached - localARC <- getsYesod appMemcachedLocal - let cKey = toMemcachedKey memcachedKey (Proxy @a) k + guard $ expiry > now + clockLeniency + $logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry + let aad = memcachedAAD cKey mExpiry + decrypted <- hoistMaybe $ AEAD.aeadOpen memcachedKey mNonce mCiphertext aad - encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey memcachedConn + $logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration" - $logDebugS "memcached" "Cache hit" + {- + let withCache = fmap (view _1) . ($ Nothing) + res <- hoistMaybe . preview (_1 . _NFDynamic) <=< withCache $ \case + Nothing -> fmap ((, length decrypted) . (, mExpiry) . review (_NFDynamic @a)) . hoistMaybe $ runGetMaybe Binary.get decrypted + Just p -> return p + -} + hoistMaybe $ runGetMaybe Binary.get decrypted - let withExp doExp = do - MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp - $logDebugS "memcached" "Decode valid" - for_ mExpiry $ \expiry -> do - now <- liftIO getPOSIXTime - guard $ expiry > now + clockLeniency - $logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry - let aad = memcachedAAD cKey mExpiry - decrypted <- hoistMaybe $ AEAD.aeadOpen memcachedKey mNonce mCiphertext aad + withExp True <|> withExp False + where + runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of + Right (bs', _, x) | null bs' -> Just x + _other -> Nothing - $logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration" - - let withCache = case localARC of - Just AppMemcachedLocal{..} -> cachedARC memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) - Nothing -> fmap (view _1) . ($ Nothing) - res <- hoistMaybe . preview (_1 . _NFDynamic) <=< withCache $ \case - Nothing -> fmap ((, length decrypted) . (, mExpiry) . review (_NFDynamic @a)) . hoistMaybe $ runGetMaybe Binary.get decrypted - Just p -> return p - - $logDebugS "memcached" "All valid" - - return res - - withExp True <|> withExp False - where - runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of - Right (bs', _, x) | null bs' -> Just x - _other -> Nothing - clockLeniency :: NominalDiffTime - clockLeniency = 2 + clockLeniency :: NominalDiffTime + clockLeniency = 2 memcachedBySet :: forall a k m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Binary k ) => Maybe Expiry -> k -> a -> m () @@ -239,7 +213,7 @@ memcachedBySet = ((void .) .) . memcachedBySet' memcachedBySet' :: forall a k m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Binary k ) => Maybe Expiry -> k -> a -> m (Maybe ByteString) @@ -252,7 +226,7 @@ memcachedBySet' mExp (Binary.encode -> k) v = do Right diff -> liftIO $ (+ realToFrac diff) <$> getPOSIXTime mConn <- getsYesod appMemcached - bsKey <- for mConn $ \AppMemcached{..} -> do + for mConn $ \AppMemcached{..} -> do mNonce <- liftIO AEAD.newNonce let cKey = toMemcachedKey memcachedKey (Proxy @a) k aad = memcachedAAD cKey mExpiry @@ -261,36 +235,17 @@ memcachedBySet' mExp (Binary.encode -> k) v = do $logDebugS "memcached" $ "Cache store: " <> tshow mExpiry return cKey - mLocal <- getsYesod appMemcachedLocal - for_ mLocal $ \AppMemcachedLocal{..} -> do - void . cachedARC memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) . const $ return ((_NFDynamic # v, mExpiry), length decrypted) - $logDebugS "memcached" $ "Cache store: " <> tshow mExpiry <> " (local ARC)" - -- DEBUG - let inv = Base64.encode . toStrict $ Binary.encode MemcachedLocalInvalidateMsg{..} - where mLocalInvalidateType = typeRepFingerprint . typeRep $ Proxy @a - mLocalInvalidateKey = k - $logDebugS "memcached" $ "To invalidate remotely: " <> tshow inv - return bsKey - memcachedByInvalidate :: forall a k m p. ( MonadHandler m, HandlerSite m ~ UniWorX , Typeable a , Binary k ) => k -> p a -> m () -memcachedByInvalidate (Binary.encode -> k) _ = arc >> memcache - where - memcache = maybeT_ $ do - AppMemcached{..} <- MaybeT $ getsYesod appMemcached - let cKey = toMemcachedKey memcachedKey (Proxy @a) k - hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey memcachedConn - $logDebugS "memcached" "Cache invalidation" - arc = maybeT_ $ do - AppMemcachedLocal{..} <- MaybeT $ getsYesod appMemcachedLocal - let arcKey = (typeRepFingerprint . typeRep $ Proxy @a, k) - atomically $ modifyTVar' memcachedLocalInvalidationQueue (:> arcKey) - void . cachedARC' memcachedLocalARC arcKey . const $ return Nothing - $logDebugS "memcached" "Cache invalidation (local ARC)" +memcachedByInvalidate (Binary.encode -> k) _ = maybeT_ $ do + AppMemcached{..} <- MaybeT $ getsYesod appMemcached + let cKey = toMemcachedKey memcachedKey (Proxy @a) k + hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey memcachedConn + $logDebugS "memcached" "Cache invalidation" data MemcachedLocalInvalidateMsg = MemcachedLocalInvalidateMsg { mLocalInvalidateType :: Fingerprint @@ -308,6 +263,7 @@ instance Binary MemcachedLocalInvalidateMsg where Binary.putWord64le w2 Binary.putLazyByteString mLocalInvalidateKey +{- manageMemcachedLocalInvalidations :: ( MonadUnliftIO m , MonadLogger m ) @@ -330,7 +286,7 @@ manageMemcachedLocalInvalidations localARC iQueue = PostgresqlChannelManager let (mLocalInvalidateType, mLocalInvalidateKey) = i return . Base64.encode . toStrict $ Binary.encode MemcachedLocalInvalidateMsg{..} } - +-} newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a } deriving newtype (Eq, Ord, Show, Binary) @@ -338,14 +294,14 @@ instance NFData a => NFData (MemcachedUnkeyed a) where rnf = rnf . unMemcachedUnkeyed memcachedGet :: ( MonadHandler m, HandlerSite m ~ UniWorX - , Typeable a, Binary a, NFData a + , Typeable a, Binary a ) => m (Maybe a) memcachedGet = fmap unMemcachedUnkeyed <$> memcachedByGet () memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a ) => Maybe Expiry -> a -> m () memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed @@ -366,7 +322,7 @@ memcachedWith (doGet, doSet) act = maybeM (act >>= doSet) pure doGet memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a ) => Maybe Expiry -> m a -> m a memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x) @@ -374,7 +330,7 @@ memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x) memcachedBy :: forall a m k. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Binary k ) => Maybe Expiry -> k -> m a -> m a @@ -394,7 +350,7 @@ newtype MemcachedKeyClassStore = MemcachedKeyClassStore{ unMemcachedKeyClassStor memcachedByClass :: forall a m k. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Binary k ) => MemcachedKeyClass -> Maybe Expiry -> k -> m a -> m a @@ -500,7 +456,7 @@ memcachedLimitedWith (doGet, doSet) liftAct (hashableDynamic -> lK) burst rate t memcachedLimited :: forall a m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a ) => Word64 -- ^ burst-size (tokens) -> Word64 -- ^ avg. inverse rate (usec/token) @@ -513,7 +469,7 @@ memcachedLimited burst rate tokens mExp = memcachedLimitedWith (memcachedGet, me memcachedLimitedKey :: forall a k' m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Typeable k', Hashable k', Eq k' ) => k' @@ -528,7 +484,7 @@ memcachedLimitedKey lK burst rate tokens mExp = memcachedLimitedWith (memcachedG memcachedLimitedBy :: forall a k m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Binary k ) => Word64 -- ^ burst-size (tokens) @@ -543,7 +499,7 @@ memcachedLimitedBy burst rate tokens mExp k = memcachedLimitedWith (memcachedByG memcachedLimitedKeyBy :: forall a k' k m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Typeable k', Hashable k', Eq k' , Binary k ) @@ -581,7 +537,7 @@ memcachedLimitedKeyByHere = do memcacheAuth :: forall m k a. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Binary k ) => k @@ -602,7 +558,7 @@ memcacheAuth k mx = cachedByBinary k $ do memcacheAuth' :: forall a m k. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Binary k ) => Expiry @@ -614,7 +570,7 @@ memcacheAuth' exp k = memcacheAuth k . (<* tell (Just $ Min exp)) . lift memcacheAuthMax :: forall m k a. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Binary k ) => Expiry @@ -728,7 +684,7 @@ memcachedTimeout :: ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m , MonadUnliftIO m , Typeable k'', Hashable k'', Eq k'' - , Typeable a, Binary a, NFData a + , Typeable a, Binary a ) => Maybe Expiry -> DiffTime -> k'' -> m a -> m (Maybe a) memcachedTimeout mExp = memcachedTimeoutWith (memcachedGet, memcachedSet mExp) @@ -737,7 +693,7 @@ memcachedTimeoutBy :: ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m , MonadUnliftIO m , Typeable k'', Hashable k'', Eq k'' - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Binary k ) => Maybe Expiry -> DiffTime -> k'' -> k -> m a -> m (Maybe a) @@ -758,7 +714,7 @@ memcachedLimitedTimeout :: forall a k'' m. , MonadThrow m , MonadUnliftIO m , Typeable k'', Hashable k'', Eq k'' - , Typeable a, Binary a, NFData a + , Typeable a, Binary a ) => Word64 -- ^ burst-size (tokens) -> Word64 -- ^ avg. inverse rate (usec/token) @@ -775,7 +731,7 @@ memcachedLimitedKeyTimeout :: forall a k' k'' m. , MonadThrow m , MonadUnliftIO m , Typeable k'', Hashable k'', Eq k'' - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Typeable k', Hashable k', Eq k' ) => k' @@ -794,7 +750,7 @@ memcachedLimitedTimeoutBy :: forall a k'' k m. , MonadThrow m , MonadUnliftIO m , Typeable k'', Hashable k'', Eq k'' - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Binary k ) => Word64 -- ^ burst-size (tokens) @@ -813,7 +769,7 @@ memcachedLimitedKeyTimeoutBy :: forall a k' k'' k m. , MonadThrow m , MonadUnliftIO m , Typeable k'', Hashable k'', Eq k'' - , Typeable a, Binary a, NFData a + , Typeable a, Binary a , Typeable k', Hashable k', Eq k' , Binary k ) diff --git a/src/Settings.hs b/src/Settings.hs index b37e2c1bb..800c3deea 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel ,-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -207,7 +207,6 @@ data AppSettings = AppSettings , appMemcachedConf :: Maybe MemcachedConf , appMemcacheAuth :: Bool - , appMemcachedLocalConf :: Maybe (ARCConf Int) , appUploadCacheConf :: Maybe Minio.ConnectInfo , appUploadCacheBucket, appUploadTmpBucket :: Minio.Bucket @@ -688,7 +687,6 @@ instance FromJSON AppSettings where appMemcachedConf <- assertM validMemcachedConf <$> o .:? "memcached" appMemcacheAuth <- o .:? "memcache-auth" .!= False - appMemcachedLocalConf <- assertM isValidARCConf <$> o .:? "memcached-local" appMailFrom <- o .: "mail-from" appMailEnvelopeFrom <- o .:? "mail-envelope-from" .!= addressEmail appMailFrom diff --git a/src/Utils.hs b/src/Utils.hs index 5c68ba25a..35c15b39d 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -44,7 +44,6 @@ import Utils.I18n as Utils import Utils.NTop as Utils import Utils.HttpConditional as Utils import Utils.Persist as Utils -import Utils.ARC as Utils import Utils.LRU as Utils import Utils.Set as Utils diff --git a/src/Utils/ARC.hs b/src/Utils/ARC.hs deleted file mode 100644 index c8086c8f1..000000000 --- a/src/Utils/ARC.hs +++ /dev/null @@ -1,344 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -{-# LANGUAGE BangPatterns #-} - -module Utils.ARC - ( ARCTick - , ARC, initARC - , arcAlterF, lookupARC, insertARC - , ARCHandle, initARCHandle, cachedARC, cachedARC' - , lookupARCHandle - , readARCHandle - , arcRecentSize, arcFrequentSize, arcGhostRecentSize, arcGhostFrequentSize - , getARCRecentWeight, getARCFrequentWeight - , describeARC - , NFDynamic(..), _NFDynamic, DynARC, DynARCHandle - ) where - -import ClassyPrelude - -import Data.HashPSQ (HashPSQ) -import qualified Data.HashPSQ as HashPSQ - -import Control.Lens - -import Type.Reflection -import Text.Show (showString, shows) - -import Data.Hashable (Hashed, hashed) - --- https://web.archive.org/web/20210115184012/https://dbs.uni-leipzig.de/file/ARC.pdf --- https://jaspervdj.be/posts/2015-02-24-lru-cache.html - - -data NFDynamic where - NFDynamic :: forall a. NFData a => TypeRep a -> a -> NFDynamic - -_NFDynamic :: forall a. (Typeable a, NFData a) => Prism' NFDynamic a -_NFDynamic = prism' toNFDyn fromNFDynamic - where - toNFDyn v = NFDynamic typeRep v - fromNFDynamic (NFDynamic t v) - | Just HRefl <- t `eqTypeRep` rep = Just v - | otherwise = Nothing - where rep = typeRep :: TypeRep a - -instance NFData NFDynamic where - rnf (NFDynamic t v) = rnfTypeRep t `seq` rnf v - -instance Show NFDynamic where - showsPrec _ (NFDynamic t _) = showString "<<" . shows t . showString ">>" - - -newtype ARCTick = ARCTick { _getARCTick :: Word64 } - deriving (Eq, Ord, Show) - deriving newtype (NFData) - -makeLenses ''ARCTick - -data ARC k w v = ARC - { arcRecent, arcFrequent :: !(HashPSQ (Hashed k) ARCTick (v, w)) - , arcGhostRecent, arcGhostFrequent :: !(HashPSQ (Hashed k) ARCTick ()) - , arcRecentWeight, arcFrequentWeight :: !w - , arcTargetRecent, arcMaximumWeight :: !w - , arcMaximumGhost :: !Int - } - -type DynARC k w = ARC (SomeTypeRep, k) w NFDynamic - -instance (NFData k, NFData w, NFData v) => NFData (ARC k w v) where - rnf ARC{..} = rnf arcRecent - `seq` rnf arcFrequent - `seq` rnf arcGhostRecent - `seq` rnf arcGhostFrequent - `seq` rnf arcRecentWeight - `seq` rnf arcFrequentWeight - `seq` rnf arcTargetRecent - `seq` rnf arcMaximumWeight - `seq` rnf arcMaximumGhost - -describeARC :: Show w - => ARC k w v - -> String -describeARC ARC{..} = intercalate ", " - [ "arcRecent: " <> show (HashPSQ.size arcRecent) - , "arcFrequent: " <> show (HashPSQ.size arcFrequent) - , "arcGhostRecent: " <> show (HashPSQ.size arcGhostRecent) - , "arcGhostFrequent: " <> show (HashPSQ.size arcGhostFrequent) - , "arcRecentWeight: " <> show arcRecentWeight - , "arcFrequentWeight: " <> show arcFrequentWeight - , "arcTargetRecent: " <> show arcTargetRecent - , "arcMaximumWeight: " <> show arcMaximumWeight - , "arcMaximumGhost: " <> show arcMaximumGhost - ] - -arcRecentSize, arcFrequentSize, arcGhostRecentSize, arcGhostFrequentSize :: ARC k w v -> Int -arcRecentSize = HashPSQ.size . arcRecent -arcFrequentSize = HashPSQ.size . arcFrequent -arcGhostRecentSize = HashPSQ.size . arcGhostRecent -arcGhostFrequentSize = HashPSQ.size . arcGhostFrequent - -getARCRecentWeight, getARCFrequentWeight :: ARC k w v -> w -getARCRecentWeight = arcRecentWeight -getARCFrequentWeight = arcFrequentWeight - -initialARCTick :: ARCTick -initialARCTick = ARCTick 0 - -initARC :: forall k w v. - Integral w - => Int -- ^ @arcMaximumGhost@ - -> w -- ^ @arcMaximumWeight@ - -> (ARC k w v, ARCTick) -initARC arcMaximumGhost arcMaximumWeight - | arcMaximumWeight < 0 = error "initARC given negative maximum weight" - | arcMaximumGhost < 0 = error "initARC given negative maximum ghost size" - | otherwise = (, initialARCTick) ARC - { arcRecent = HashPSQ.empty - , arcFrequent = HashPSQ.empty - , arcGhostRecent = HashPSQ.empty - , arcGhostFrequent = HashPSQ.empty - , arcRecentWeight = 0 - , arcFrequentWeight = 0 - , arcMaximumWeight - , arcTargetRecent = 0 - , arcMaximumGhost - } - - -infixl 6 |- -(|-) :: (Num a, Ord a) => a -> a -> a -(|-) m s - | s >= m = 0 - | otherwise = m - s - - -arcAlterF :: forall f k w v. - ( Ord k, Hashable k - , Functor f - , Integral w - , NFData k, NFData w, NFData v - ) - => k - -> (Maybe (v, w) -> f (Maybe (v, w))) - -> ARC k w v - -> ARCTick -> f (ARC k w v, ARCTick) --- | Unchecked precondition: item weights are always less than `arcMaximumWeight` -arcAlterF !(force -> unhashedK@(hashed -> k)) f oldARC@ARC{..} now - | later <= initialARCTick = uncurry (arcAlterF unhashedK f) $ initARC arcMaximumGhost arcMaximumWeight - | otherwise = (, later) <$> if - | Just (_p, x@(_, w), arcFrequent') <- HashPSQ.deleteView k arcFrequent - -> f (Just x) <&> \case - Nothing -> oldARC - { arcFrequent = arcFrequent' - , arcGhostFrequent = HashPSQ.insert k now () arcGhostFrequent - , arcFrequentWeight = arcFrequentWeight - w - } - Just !(force -> x'@(_, w')) - -> let (arcFrequent'', arcFrequentWeight'', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent' (arcFrequentWeight - w) arcGhostFrequent - in oldARC - { arcFrequent = HashPSQ.insert k now x' arcFrequent'' - , arcFrequentWeight = arcFrequentWeight'' + w' - , arcGhostFrequent = arcGhostFrequent' - } - | Just (_p, x@(_, w), arcRecent') <- HashPSQ.deleteView k arcRecent - -> f (Just x) <&> \case - Nothing -> oldARC - { arcRecent = arcRecent' - , arcGhostRecent = HashPSQ.insert k now () $ evictGhostToCount arcGhostRecent - , arcRecentWeight = arcRecentWeight - w - } - Just !(force -> x'@(_, w')) - -> let (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent arcFrequentWeight arcGhostFrequent - in oldARC - { arcRecent = arcRecent' - , arcRecentWeight = arcRecentWeight - w - , arcFrequent = HashPSQ.insert k now x' arcFrequent' - , arcFrequentWeight = arcFrequentWeight' + w' - , arcGhostFrequent = arcGhostFrequent' - } - | Just (_p, (), arcGhostRecent') <- HashPSQ.deleteView k arcGhostRecent - -> f Nothing <&> \case - Nothing -> oldARC - { arcGhostRecent = HashPSQ.insert k now () arcGhostRecent' - } - Just !(force -> x@(_, w)) - -> let arcTargetRecent' = min arcMaximumWeight $ arcTargetRecent + max avgWeight (round $ toRational (HashPSQ.size arcGhostFrequent) / toRational (HashPSQ.size arcGhostRecent) * toRational avgWeight) - (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent - (arcRecent', arcRecentWeight', arcGhostRecent'') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent' - in oldARC - { arcRecent = arcRecent' - , arcFrequent = HashPSQ.insert k now x arcFrequent' - , arcGhostRecent = arcGhostRecent'' - , arcGhostFrequent = arcGhostFrequent' - , arcRecentWeight = arcRecentWeight' - , arcFrequentWeight = arcFrequentWeight' + w - , arcTargetRecent = arcTargetRecent' - } - | Just (_p, (), arcGhostFrequent') <- HashPSQ.deleteView k arcGhostFrequent - -> f Nothing <&> \case - Nothing -> oldARC - { arcGhostFrequent = HashPSQ.insert k now () arcGhostFrequent' - } - Just !(force -> x@(_, w)) - -> let arcTargetRecent' = arcTargetRecent |- max avgWeight (round $ toRational (HashPSQ.size arcGhostRecent) / toRational (HashPSQ.size arcGhostFrequent) * toRational avgWeight) - (arcFrequent', arcFrequentWeight', arcGhostFrequent'') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent' - (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent - in oldARC - { arcRecent = arcRecent' - , arcFrequent = HashPSQ.insert k now x arcFrequent' - , arcGhostRecent = arcGhostRecent' - , arcGhostFrequent = arcGhostFrequent'' - , arcRecentWeight = arcRecentWeight' - , arcFrequentWeight = arcFrequentWeight' + w - , arcTargetRecent = arcTargetRecent' - } - | otherwise -> f Nothing <&> \case - Nothing -> oldARC - { arcGhostRecent = HashPSQ.insert k now () $ evictGhostToCount arcGhostRecent - } - Just !(force -> x@(_, w)) - -> let (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent (arcMaximumWeight |- arcFrequentWeight) |- w) arcRecent arcRecentWeight arcGhostRecent - in oldARC - { arcRecent = HashPSQ.insert k now x arcRecent' - , arcRecentWeight = arcRecentWeight' + w - , arcGhostRecent = arcGhostRecent' - } - where - avgWeight = round $ toRational (arcRecentWeight + arcFrequentWeight) / toRational (HashPSQ.size arcFrequent + HashPSQ.size arcRecent) - - later :: ARCTick - later = over getARCTick succ now - - evictToSize :: w -> HashPSQ (Hashed k) ARCTick (v, w) -> w -> HashPSQ (Hashed k) ARCTick () -> (HashPSQ (Hashed k) ARCTick (v, w), w, HashPSQ (Hashed k) ARCTick ()) - evictToSize tSize c cSize ghostC - | cSize <= tSize = (c, cSize, ghostC) - | Just (k', p', (_, w'), c') <- HashPSQ.minView c = evictToSize tSize c' (cSize - w') . evictGhostToCount $ HashPSQ.insert k' p' () ghostC - | otherwise = error "evictToSize: cannot reach required size through eviction" - - evictGhostToCount :: HashPSQ (Hashed k) ARCTick () -> HashPSQ (Hashed k) ARCTick () - evictGhostToCount c - | HashPSQ.size c <= arcMaximumGhost = c - | Just (_, _, _, c') <- HashPSQ.minView c = evictGhostToCount c' - | otherwise = error "evictGhostToCount: cannot reach required count through eviction" - -lookupARC :: forall k w v. - ( Ord k, Hashable k - , Integral w - , NFData k, NFData w, NFData v - ) - => k - -> (ARC k w v, ARCTick) - -> Maybe (v, w) -lookupARC k = getConst . uncurry (arcAlterF k Const) - -insertARC :: forall k w v. - ( Ord k, Hashable k - , Integral w - , NFData k, NFData w, NFData v - ) - => k - -> Maybe (v, w) - -> ARC k w v - -> ARCTick -> (ARC k w v, ARCTick) -insertARC k newVal = (runIdentity .) . arcAlterF k (const $ pure newVal) - - -newtype ARCHandle k w v = ARCHandle { _getARCHandle :: IORef (ARC k w v, ARCTick) } - deriving (Eq) - -type DynARCHandle k w = ARCHandle (SomeTypeRep, k) w NFDynamic - -initARCHandle :: forall k w v m. - ( MonadIO m - , Integral w - ) - => Int -- ^ @arcMaximumGhost@ - -> w -- ^ @arcMaximumWeight@ - -> m (ARCHandle k w v) -initARCHandle maxGhost maxWeight = fmap ARCHandle . newIORef $ initARC maxGhost maxWeight - -cachedARC' :: forall k w v m. - ( MonadIO m - , Ord k, Hashable k - , Integral w - , NFData k, NFData w, NFData v - ) - => ARCHandle k w v - -> k - -> (Maybe (v, w) -> m (Maybe (v, w))) - -> m (Maybe v) -cachedARC' (ARCHandle arcVar) k f = do - oldVal <- lookupARC k <$> readIORef arcVar - newVal <- f oldVal - atomicModifyIORef' arcVar $ (, ()) . uncurry (insertARC k newVal) - -- Using `modifyIORef'` instead of `atomicModifyIORef'` might very - -- well drop newer values computed during the update. - -- - -- This was deemed unacceptable due to the risk of cache - -- invalidations being silently dropped - -- - -- Another alternative would be to use "optimistic locking", - -- i.e. read the current value of `arcVar`, compute an updated - -- version, and write it back atomically iff the `ARCTick` hasn't - -- changed. - -- - -- This was not implemented in the hopes that atomicModifyIORef' - -- already offers sufficient performance. - -- - -- If optimistic locking is implemented there is a risk of - -- performance issues due to the overhead and contention likely - -- associated with the atomic transaction required for the "compare - -- and swap" - return $ view _1 <$> newVal - -cachedARC :: forall k w v m. - ( MonadIO m - , Ord k, Hashable k - , Integral w - , NFData k, NFData w, NFData v - ) - => ARCHandle k w v - -> k - -> (Maybe (v, w) -> m (v, w)) - -> m v -cachedARC h k f = fromMaybe (error "cachedARC: cachedARC' returned Nothing") <$> cachedARC' h k (fmap Just . f) - -lookupARCHandle :: forall k w v m. - ( MonadIO m - , Ord k, Hashable k - , Integral w - , NFData k, NFData w, NFData v - ) - => ARCHandle k w v - -> k - -> m (Maybe (v, w)) -lookupARCHandle (ARCHandle arcVar) k = lookupARC k <$> readIORef arcVar - - -readARCHandle :: MonadIO m - => ARCHandle k w v - -> m (ARC k w v, ARCTick) -readARCHandle (ARCHandle arcVar) = readIORef arcVar diff --git a/src/Utils/LRU.hs b/src/Utils/LRU.hs index 8b8daa079..66517d70d 100644 --- a/src/Utils/LRU.hs +++ b/src/Utils/LRU.hs @@ -66,11 +66,11 @@ initLRU :: forall k t w v. -> (LRU k t w v, LRUTick) initLRU lruMaximumWeight | lruMaximumWeight < 0 = error "initLRU given negative maximum weight" - | otherwise = (, initialLRUTick) LRU - { lruStore = OrdPSQ.empty - , lruWeight = 0 - , lruMaximumWeight - } + | otherwise = (lru, initialLRUTick) + where lru = LRU { lruStore = OrdPSQ.empty + , lruWeight = 0 + , lruMaximumWeight + } insertLRU :: forall k t w v. ( Ord k, Ord t @@ -84,18 +84,18 @@ insertLRU :: forall k t w v. insertLRU k t newVal oldLRU@LRU{..} now | later <= initialLRUTick = uncurry (insertLRU k t newVal) $ initLRU lruMaximumWeight | Just (_, w) <- newVal, w > lruMaximumWeight = (oldLRU, now) - | Just (_, w) <- newVal = (, later) $ + | Just (_, w) <- newVal = (, later) $ let (lruStore', lruWeight') = evictToSize (lruMaximumWeight - w) lruStore lruWeight (fromMaybe 0 . preview (_Just . _2 . _2) -> oldWeight, lruStore'') = OrdPSQ.alter (, ((t, now), ) <$> newVal) k lruStore' - in oldLRU - { lruStore = lruStore'' - , lruWeight = lruWeight' - oldWeight + w - } - | Just (_, (_, w), lruStore') <- OrdPSQ.deleteView k lruStore = (, now) oldLRU - { lruStore = lruStore' - , lruWeight = lruWeight - w - } + in oldLRU { lruStore = lruStore'' + , lruWeight = lruWeight' - oldWeight + w + } + | Just (_, (_, w), lruStore') <- OrdPSQ.deleteView k lruStore = + let lru = oldLRU { lruStore = lruStore' + , lruWeight = lruWeight - w + } + in (lru, now) | otherwise = (oldLRU, now) where later :: LRUTick @@ -127,9 +127,9 @@ touchLRU k t oldLRU@LRU{..} now , later <= initialLRUTick = (, Just v) . uncurry (insertLRU k t $ Just v) $ initLRU lruMaximumWeight | (Just (_, v), lruStore') <- altered = ((oldLRU{ lruStore = lruStore' }, later), Just v) | otherwise = ((oldLRU, now), Nothing) - where + where altered = OrdPSQ.alter (\oldVal -> (oldVal, over _1 (max (t, later)) <$> oldVal)) k lruStore - + later :: LRUTick later = over getLRUTick succ now diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index e1f07dfc4..4eeefbb75 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -19,8 +19,6 @@ module Utils.Metrics , observeDeletedUnreferencedFiles, observeDeletedUnreferencedChunks, observeInjectedFiles, observeRechunkedFiles , registerJobWorkerQueueDepth , observeMissingFiles - , ARCMetrics, ARCLabel(..) - , arcMetrics , LRUMetrics, LRULabel(..) , lruMetrics , InjectInhibitMetrics, injectInhibitMetrics @@ -215,7 +213,7 @@ injectedFilesBytes :: Counter injectedFilesBytes = unsafeRegister $ counter info where info = Info "uni2work_injected_files_bytes" "Size of files injected from upload cache into database" - + {-# NOINLINE rechunkedFiles #-} rechunkedFiles :: Counter rechunkedFiles = unsafeRegister $ counter info @@ -269,46 +267,11 @@ favouritesSkippedDueToDBLoad :: Counter favouritesSkippedDueToDBLoad = unsafeRegister $ counter info where info = Info "uni2work_favourites_skipped_due_to_db_load_count" "Number of times this Uni2work-instance skipped generating FavouriteQuickActions due to database pressure" - + relabel :: Text -> Text -> SampleGroup -> SampleGroup relabel l s (SampleGroup i t ss) = SampleGroup i t . flip map ss $ \(Sample k lbls v) -> Sample k ((l, s) : filter (views _1 $ (/=) l) lbls) v -data ARCMetrics = ARCMetrics - -data ARCLabel = ARCFileSource | ARCMemcachedLocal - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) - deriving anyclass (Universe, Finite) - -nullaryPathPiece ''ARCLabel $ camelToPathPiece' 1 - -arcMetrics :: Integral w - => ARCLabel - -> ARCHandle k w v - -> Metric ARCMetrics -arcMetrics lbl ah = Metric $ return (ARCMetrics, collectARCMetrics) - where - labelArc = relabel "arc" - - collectARCMetrics = map (labelArc $ toPathPiece lbl) <$> do - (arc, _) <- readARCHandle ah - return - [ SampleGroup sizeInfo GaugeType - [ Sample "arc_size" [("lru", "ghost-recent")] . encodeUtf8 . tshow $ arcGhostRecentSize arc - , Sample "arc_size" [("lru", "recent")] . encodeUtf8 . tshow $ arcRecentSize arc - , Sample "arc_size" [("lru", "frequent")] . encodeUtf8 . tshow $ arcFrequentSize arc - , Sample "arc_size" [("lru", "ghost-frequent")] . encodeUtf8 . tshow $ arcGhostFrequentSize arc - ] - , SampleGroup weightInfo GaugeType - [ Sample "arc_weight" [("lru", "recent")] . encodeUtf8 . tshow . toInteger $ getARCRecentWeight arc - , Sample "arc_weight" [("lru", "frequent")] . encodeUtf8 . tshow . toInteger $ getARCFrequentWeight arc - ] - ] - sizeInfo = Info "arc_size" - "Number of entries in the ARC LRUs" - weightInfo = Info "arc_weight" - "Sum of weights of entries in the ARC LRUs" - data LRUMetrics = LRUMetrics data LRULabel = LRUFileSourcePrewarm @@ -356,9 +319,9 @@ injectInhibitMetrics tvar = Metric $ return (InjectInhibitMetrics, collectInject [ Sample "uni2work_inject_inhibited_hashes_count" [] . encodeUtf8 . tshow . Set.size $ F.fold inhibits ] ] - intervalsInfo = Info "uni2work_inject_inhibited_intervals_count" + intervalsInfo = Info "uni2work_inject_inhibited_intervals_count" "Number of distinct time intervals in which we don't transfer some files from upload cache to db" - hashesInfo = Info "uni2work_inject_inhibited_hashes_count" + hashesInfo = Info "uni2work_inject_inhibited_hashes_count" "Number of files which we don't transfer from upload cache to db during some interval" data PoolMetrics = PoolMetrics @@ -392,12 +355,12 @@ poolMetrics lbl pool = Metric $ return (PoolMetrics, collectPoolMetrics) [ Sample "uni2work_pool_uses_count" [] . encodeUtf8 $ tshow usesCount ] ] - - availableInfo = Info "uni2work_pool_available_count" + + availableInfo = Info "uni2work_pool_available_count" "Number of open resources available for taking" - inUseInfo = Info "uni2work_pool_in_use_count" + inUseInfo = Info "uni2work_pool_in_use_count" "Number of resources currently in use" - usesInfo = Info "uni2work_pool_uses_count" + usesInfo = Info "uni2work_pool_uses_count" "Number of takes executed against the pool" {-# NOINLINE databaseConnDuration #-} @@ -407,7 +370,7 @@ databaseConnDuration = unsafeRegister . vector "label" $ histogram info buckets info = Info "uni2work_database_conn_duration_seconds" "Duration of use of a database connection from the pool" buckets = histogramBuckets 50e-6 5000 - + data DBConnUseState = DBConnUseState { dbConnUseStart :: !TimeSpec , dbConnUseLabel :: !CallStack @@ -441,7 +404,7 @@ authTagEvaluationDuration = unsafeRegister . vector ("tag", "outcome", "handler" info = Info "uni2work_auth_tag_evaluation_duration_seconds" "Duration of auth tag evaluations" buckets = histogramBuckets 5e-6 1 - + withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport withHealthReportMetrics act = do @@ -599,7 +562,7 @@ observeAuthTagEvaluation aTag handler act = do let outcome = case res of Right (_, outcome') -> outcome' Left _ -> OutcomeException - + liftIO . withLabel authTagEvaluationDuration (toPathPiece aTag, toPathPiece outcome, pack handler) . flip observe . realToFrac $ end - start either throwIO (views _1 return) res From cb58c20ca14e3dfdf07ecff8ebaf7ab9094cfdde Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 24 Sep 2024 11:21:33 +0200 Subject: [PATCH 024/187] chore(occurrences): add datatype LessonTime for dealing timetable intervals --- src/Handler/LMS.hs | 2 +- src/Handler/Qualification.hs | 2 +- src/Handler/School/DayTasks.hs | 8 ++-- src/Handler/Utils/Files.hs | 1 + src/Handler/Utils/Occurrences.hs | 59 ++++++++++++++++++++++++-- src/Utils/Files.hs | 13 +++--- templates/tutorial-participants.hamlet | 3 +- 7 files changed, 72 insertions(+), 16 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 9821c2309..cf8c25a68 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -436,7 +436,7 @@ mkLmsTable :: ( Functor h, ToSortable h mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do now <- liftIO getCurrentTime -- lookup all companies - cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do + cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 8ca169696..e5c872494 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -363,7 +363,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do svs <- getSupervisees now <- liftIO getCurrentTime -- lookup all companies - cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do + cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 0dd956333..273427f35 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -81,14 +81,14 @@ getDayTutorials ssh dlimit@(dstart, dend ) E.where_ $ crs E.^. CourseSchool E.==. E.val ssh E.&&. trm E.^. TermStart E.<=. E.val dend E.&&. trm E.^. TermEnd E.>=. E.val dstart - return (trm, tut) - $logErrorS "memcached" $ "***DEBUG*****CACHE*****" <> tshow (ssh,dlimit) <> "***************" -- DEBUG ONLY + return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart)) return $ mapMaybe checkCandidate candidates where period = Set.fromAscList [dstart..dend] - checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}) - | not $ Set.null $ Set.intersection period $ occurrencesCompute trm occ + checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- common case + checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}},_) + | not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ = Just tutId | otherwise = Nothing diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index b8a4a8cd2..a9de3f095 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -30,6 +30,7 @@ import qualified Database.Esqueleto.Utils as E import System.FilePath (normalise, makeValid) import Data.List (dropWhileEnd) +{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} data SourceFilesException diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index f5fc0b9fa..e2ddf5964 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -3,8 +3,10 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Utils.Occurrences - ( occurrencesWidget - , occurrencesCompute + ( LessonTime(..) + , occurringLessons + , occurrencesWidget + , occurrencesCompute, occurrencesCompute' , occurrencesBounds , occurrencesAddBusinessDays ) where @@ -19,6 +21,52 @@ import Utils.Occurrences import Handler.Utils.DateTime + + +---------------- +-- LessonTime -- +---------------- +-- +-- Model time intervals to compute lecture/tutorial lessons more intuitively +-- + +data LessonTime = LessonTime { lessonStart, lessonEnd :: LocalTime } + deriving (Eq, Ord, Read, Show, Generic) -- BEWARE: Ord instance might not be intuitive, but needed for Set + +occurringLessons :: Term -> Occurrences -> Set LessonTime +occurringLessons t Occurrences{..} = Set.union exceptOcc $ Set.filter isExcept scheduledLessons + where + scheduledLessons = occurrenceScheduleToLessons t `foldMap` occurrencesScheduled + (exceptOcc, exceptNo) = occurrenceExceptionToLessons occurrencesExceptions + isExcept LessonTime{lessonStart} = Set.member lessonStart exceptNo + +occurrenceScheduleToLessons :: Term -> OccurrenceSchedule -> Set LessonTime +occurrenceScheduleToLessons Term{..} = + let setHolidays = Set.fromList termHolidays + in \ScheduleWeekly{..} -> + let occDays = daysOfWeekBetween (termLectureStart, termLectureEnd) scheduleDayOfWeek \\ setHolidays + toLesson d = LessonTime { lessonStart = LocalTime d scheduleStart + , lessonEnd = LocalTime d scheduleEnd + } + in Set.map toLesson occDays + +occurrenceExceptionToLessons :: Set OccurrenceException -> (Set LessonTime, Set LocalTime) +occurrenceExceptionToLessons = Set.foldr aux mempty + where + aux ExceptOccur{..} (oc,no) = + let t = LessonTime { lessonStart = LocalTime exceptDay exceptStart + , lessonEnd = LocalTime exceptDay exceptEnd + } + in (Set.insert t oc,no) + aux ExceptNoOccur{..} (oc,no) = + (oc, Set.insert exceptTime no) + + +----------------- +-- Occurrences -- +----------------- + + occurrencesWidget :: JSONB Occurrences -> Widget occurrencesWidget (normalizeOccurrences . unJSONB -> Occurrences{..}) = do let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case @@ -36,7 +84,12 @@ occurrencesWidget (normalizeOccurrences . unJSONB -> Occurrences{..}) = do $(widgetFile "widgets/occurrence/cell/except-no-occur") $(widgetFile "widgets/occurrence/cell") --- | Get all occurrences during a term, excluding term holidays from the regular schedule, but not from exceptins +-- | More precise verison of `occurrencesCompute`, which accounts for TimeOfDay as well +occurrencesCompute' :: Term -> Occurrences -> Set Day +occurrencesCompute' trm occ = Set.map (localDay . lessonStart) $ occurringLessons trm occ + +-- | Get all occurrences during a term, excluding term holidays from the regular schedule, but not from exceptions +-- Beware: code currently ignores TimeOfDay, see Model.Types.DateTime.LessonTime for a start to address this if needed occurrencesCompute :: Term -> Occurrences -> Set Day occurrencesCompute Term{..} Occurrences{..} = ((scdDays \\ Set.fromList termHolidays) <> plsDays) \\ excDays where diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index 4358c947b..d49824d7d 100644 --- a/src/Utils/Files.hs +++ b/src/Utils/Files.hs @@ -48,6 +48,7 @@ import System.IO.Unsafe import Data.Typeable (eqT) +{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} sinkFileDB :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => Bool -- ^ Replace? Use only in serializable transaction @@ -63,9 +64,9 @@ sinkFileDB doReplace fileContentContent = do observeSunkChunk StorageDB $ olength fileContentChunkContent tellM $ Set.singleton <$> insert FileChunkLock{ fileChunkLockHash = fileContentChunkHash, .. } - + existsChunk <- lift $ exists [FileContentChunkHash ==. fileContentChunkHash] - + let setContentBased = updateWhere [FileContentChunkHash ==. fileContentChunkHash] [FileContentChunkContentBased =. fileContentChunkContentBased] if | existsChunk -> lift setContentBased | otherwise -> lift . handleIfSql isUniqueConstraintViolation (const setContentBased) $ @@ -98,7 +99,7 @@ sinkFileDB doReplace fileContentContent = do | otherwise -> do deleteWhere [ FileContentEntryHash ==. fileContentHash ] insertEntries - + return fileContentHash where fileContentChunkContentBased = True @@ -163,18 +164,18 @@ sinkMinio content = do , Minio.dstObject = dstName } uploadExists <- handleIf minioIsDoesNotExist (const $ return False) $ True <$ Minio.statObject uploadBucket dstName Minio.defaultGetObjectOptions - unless uploadExists $ + unless uploadExists $ Minio.copyObject copyDst copySrc release removeObject return $ _sinkMinioRet # contentHash - + sinkFileMinio :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) => ConduitT () ByteString m () -> MaybeT m FileContentReference -- ^ Cannot deal with zero length uploads sinkFileMinio = sinkMinio @FileContentReference - + sinkFiles :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT (File (SqlPersistT m)) FileReference (SqlPersistT m) () sinkFiles = C.mapM sinkFile diff --git a/templates/tutorial-participants.hamlet b/templates/tutorial-participants.hamlet index c01779c73..0eae86644 100644 --- a/templates/tutorial-participants.hamlet +++ b/templates/tutorial-participants.hamlet @@ -15,4 +15,5 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $forall (Entity _ usr) <- tutors
  • ^{userEmailWidget usr} -^{participantTable} +
    + ^{participantTable} From 36b481a548b680029e930962fed382b6514cdb2e Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 24 Sep 2024 13:05:16 +0200 Subject: [PATCH 025/187] fix(occurrences): occurringLessons had an erroneously inverted condition --- src/Handler/School/DayTasks.hs | 7 ++-- src/Handler/Utils/Occurrences.hs | 56 +++++++++++++++++++++++++++----- 2 files changed, 51 insertions(+), 12 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 273427f35..ae3ad0dc4 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -71,9 +71,9 @@ data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day) deriving anyclass (Hashable, Binary) getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] -getDayTutorials ssh dlimit@(dstart, dend ) +getDayTutorials ssh _dlimit@(dstart, dend ) | dstart > dend = return mempty - | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do + | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ candidates <- E.select $ do (trm :& crs :& tut) <- E.from $ E.table @Term `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) @@ -82,11 +82,12 @@ getDayTutorials ssh dlimit@(dstart, dend ) E.&&. trm E.^. TermStart E.<=. E.val dend E.&&. trm E.^. TermEnd E.>=. E.val dstart return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart)) + $logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates return $ mapMaybe checkCandidate candidates where period = Set.fromAscList [dstart..dend] - checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- common case + -- TODO: checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- common case checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}},_) | not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ = Just tutId diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index e2ddf5964..a4d8e7b14 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -20,7 +20,7 @@ import Utils.Occurrences import Handler.Utils.DateTime - +-- import Text.Read (read) -- for DEBUGGING only ---------------- @@ -38,7 +38,7 @@ occurringLessons t Occurrences{..} = Set.union exceptOcc $ Set.filter isExcept s where scheduledLessons = occurrenceScheduleToLessons t `foldMap` occurrencesScheduled (exceptOcc, exceptNo) = occurrenceExceptionToLessons occurrencesExceptions - isExcept LessonTime{lessonStart} = Set.member lessonStart exceptNo + isExcept LessonTime{lessonStart} = Set.notMember lessonStart exceptNo occurrenceScheduleToLessons :: Term -> OccurrenceSchedule -> Set LessonTime occurrenceScheduleToLessons Term{..} = @@ -84,14 +84,13 @@ occurrencesWidget (normalizeOccurrences . unJSONB -> Occurrences{..}) = do $(widgetFile "widgets/occurrence/cell/except-no-occur") $(widgetFile "widgets/occurrence/cell") --- | More precise verison of `occurrencesCompute`, which accounts for TimeOfDay as well -occurrencesCompute' :: Term -> Occurrences -> Set Day -occurrencesCompute' trm occ = Set.map (localDay . lessonStart) $ occurringLessons trm occ - --- | Get all occurrences during a term, excluding term holidays from the regular schedule, but not from exceptions --- Beware: code currently ignores TimeOfDay, see Model.Types.DateTime.LessonTime for a start to address this if needed +-- | Get all days of occurrences during a term, excluding term holidays from the regular schedule, but not from do-occur exceptions occurrencesCompute :: Term -> Occurrences -> Set Day -occurrencesCompute Term{..} Occurrences{..} = ((scdDays \\ Set.fromList termHolidays) <> plsDays) \\ excDays +occurrencesCompute trm occ = Set.map (localDay . lessonStart) $ occurringLessons trm occ + +-- | Less precise versison of `occurrencesCompute`, which ignores TimeOfDay; might be faster, but could be wrong in some cases +occurrencesCompute' :: Term -> Occurrences -> Set Day +occurrencesCompute' Term{..} Occurrences{..} = ((scdDays \\ Set.fromList termHolidays) <> plsDays) \\ excDays where scdDays = Set.foldr getOccDays mempty occurrencesScheduled (plsDays,excDays) = Set.foldr getExcDays mempty occurrencesExceptions @@ -133,3 +132,42 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc where ed = dayOfOccurrenceException ex nd = addDays offset ed + + + +{- + +----------- +-- DEBUG -- +----------- +theorieschulung :: Occurrences +theorieschulung = + Occurrences + {occurrencesScheduled = Set.fromList + [ScheduleWeekly {scheduleDayOfWeek = Thursday, scheduleStart = read "11:11:00", scheduleEnd = read "12:22:00"} + ,ScheduleWeekly {scheduleDayOfWeek = Friday , scheduleStart = read "13:33:00", scheduleEnd = read "14:44:00"} + ,ScheduleWeekly {scheduleDayOfWeek = Sunday , scheduleStart = read "15:55:00", scheduleEnd = read "16:06:00"} + ] + , occurrencesExceptions = Set.fromList + [ExceptOccur {exceptDay = read "2024-01-07", exceptStart = read "08:30:00", exceptEnd = read "16:00:00"} + ,ExceptOccur {exceptDay = read "2024-01-15", exceptStart = read "09:00:00", exceptEnd = read "16:00:00"} + ,ExceptOccur {exceptDay = read "2024-09-24", exceptStart = read "09:10:00", exceptEnd = read "16:10:00"} + ,ExceptNoOccur {exceptTime = read "2024-02-25 15:55:00"} + ,ExceptNoOccur {exceptTime = read "2024-10-25 13:33:00"} + ,ExceptNoOccur {exceptTime = read "2024-11-08 08:08:08"} -- causes difference between occurrencesCompute and occurrencesCompute' + ,ExceptNoOccur {exceptTime = read "2024-11-09 11:11:08"} + ] + } + +exampleTerm :: Term +exampleTerm = Term + { termName = TermIdentifier {year = 2024} + , termStart = read "2024-01-01" + , termEnd = read "2024-12-29" + , termHolidays = [read "2024-01-01", read "2024-03-29", read "2024-03-31", read "2024-04-01", read "2024-05-01", read "2024-05-09" + ,read "2024-05-19", read "2024-05-20", read "2024-05-30", read "2024-10-03", read "2024-12-24", read "2024-12-25", read "2024-12-26" ] + , termLectureStart = read "2024-01-01" + , termLectureEnd = read "2024-12-27" + } + +-} \ No newline at end of file From 692350677fb66b070d0a6f89e8bb3bc6c1dea9d1 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 24 Sep 2024 13:10:14 +0200 Subject: [PATCH 026/187] fix(build): minor --- src/Handler/School/DayTasks.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index ae3ad0dc4..3bec3d289 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -71,9 +71,9 @@ data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day) deriving anyclass (Hashable, Binary) getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] -getDayTutorials ssh _dlimit@(dstart, dend ) +getDayTutorials ssh dlimit@(dstart, dend ) | dstart > dend = return mempty - | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ + | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do candidates <- E.select $ do (trm :& crs :& tut) <- E.from $ E.table @Term `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) @@ -82,7 +82,7 @@ getDayTutorials ssh _dlimit@(dstart, dend ) E.&&. trm E.^. TermStart E.<=. E.val dend E.&&. trm E.^. TermEnd E.>=. E.val dstart return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart)) - $logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates + -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates return $ mapMaybe checkCandidate candidates where period = Set.fromAscList [dstart..dend] From 35cadda2e86016ea8abeeb039dadc205cf3767ec Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 24 Sep 2024 17:15:15 +0200 Subject: [PATCH 027/187] refactor(occurrences): fold RoomReference into Occurrences (WIP) Each Occurrence now has its own RoomReference, i.e. Mondays may have a different Room assigned than Tuesdays WIP Problem: occurrencesAFrom does not work, always insists on Room missing --- messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Handler/Course/Events/Delete.hs | 2 +- src/Handler/Course/Show.hs | 27 ++++++++++--------- src/Handler/Course/User.hs | 2 +- src/Handler/Tutorial/List.hs | 19 +++++++------ src/Handler/Utils/Form/Occurrences.hs | 3 +++ src/Handler/Utils/Occurrences.hs | 12 ++++----- src/Handler/Utils/Table/Cells.hs | 7 ++--- src/Handler/Utils/Widgets.hs | 4 +-- src/Model/Types/DateTime.hs | 17 +++++++----- src/Utils.hs | 9 ++++++- src/Utils/Occurrences.hs | 15 ++++++----- templates/course.hamlet | 2 +- templates/tutorial-participants.hamlet | 2 +- .../occurrence/cell/except-no-occurr.hamlet | 7 ----- .../occurrence/cell/except-occur.hamlet | 4 ++- .../occurrence/cell/except-occurr.hamlet | 7 ----- .../widgets/occurrence/cell/weekly.hamlet | 4 ++- .../occurrence/form/except-occur.hamlet | 2 +- .../widgets/occurrence/form/weekly.hamlet | 2 +- test/Database/Fill.hs | 13 +++++++++ 22 files changed, 95 insertions(+), 67 deletions(-) delete mode 100644 templates/widgets/occurrence/cell/except-no-occurr.hamlet delete mode 100644 templates/widgets/occurrence/cell/except-occurr.hamlet diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 166aa413a..4b9e83764 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -91,6 +91,7 @@ UtilExamResultVoided: Entwertet CourseOption tid@TermId ssh@SchoolId csh@CourseShorthand coursen@CourseName !ident-ok: #{tid} - #{ssh} - #{csh}: #{coursen} RoomReferenceNone !ident-ok: — RoomReferenceSimple !ident-ok: Text +RoomReferenceSimpleAt r@Text: in Raum #{r} RoomReferenceLink: Link & Anweisungen RoomReferenceSimpleText: Raum RoomReferenceSimpleTextPlaceholder: Raum diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 7c417bb4c..c4c694c69 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -91,6 +91,7 @@ UtilExamResultVoided: Voided CourseOption tid ssh csh coursen: #{tid} - #{ssh} - #{csh}: #{coursen} RoomReferenceNone: — RoomReferenceSimple: Text +RoomReferenceSimpleAt r: at room #{r} RoomReferenceLink: Link & Instructions RoomReferenceSimpleText: Room RoomReferenceSimpleTextPlaceholder: Room diff --git a/src/Handler/Course/Events/Delete.hs b/src/Handler/Course/Events/Delete.hs index 7dfcdcba2..179be19bf 100644 --- a/src/Handler/Course/Events/Delete.hs +++ b/src/Handler/Course/Events/Delete.hs @@ -34,7 +34,7 @@ postCEvDeleteR tid ssh csh cID = do $maybe room <- courseEventRoom , #{roomReferenceText room} : - ^{occurrencesWidget courseEventTime} + ^{occurrencesWidget False courseEventTime} |] drRecordConfirmString :: Entity CourseEvent -> DB Text diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 78ddeecd5..a9ba08cbf 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -29,7 +29,7 @@ import Handler.Exam.List (mkExamTable) getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do - mbAid <- maybeAuthId + mbAid <- maybeAuthId now <- liftIO getCurrentTime (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,administrators,correctors,tutors,news,events,submissionGroup,_mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial),courseQualifications) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] @@ -146,7 +146,7 @@ getCShowR tid ssh csh = do | otherwise -> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR - mayMassRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR + mayMassRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR MsgRenderer mr <- getMsgRenderer @@ -154,14 +154,14 @@ getCShowR tid ssh csh = do tutorialDBTable = DBTable{..} where resultTutorial :: Lens' (DBRow (Entity Tutorial, Bool)) (Entity Tutorial) - resultTutorial = _dbrOutput . _1 - resultShowRoom = _dbrOutput . _2 - + resultTutorial = _dbrOutput . _1 + resultHideRoom = _dbrOutput . _2 + dbtSQLQuery tutorial = do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - let showRoom = maybe E.false (flip showTutorialRoom tutorial . E.val) mbAid - E.||. E.not_ (tutorial E.^. TutorialRoomHidden) - return (tutorial, showRoom) + let hideRoom = maybe E.true (E.not__ . flip showTutorialRoom tutorial . E.val) mbAid + E.&&. (tutorial E.^. TutorialRoomHidden) + return (tutorial, hideRoom) dbtRowKey = (E.^. TutorialId) dbtProj = over (_dbrOutput . _2) E.unValue <$> dbtProjId dbtColonnade = dbColonnade $ mconcat @@ -180,10 +180,13 @@ getCShowR tid ssh csh = do
  • ^{nameEmailWidget' tutor} |] - , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if - | res ^. resultShowRoom -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res + , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if -- TODO REMOVE + | res ^. resultHideRoom . _not -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res | otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text) - , sortable Nothing (i18nCell MsgTableTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime + , sortable Nothing (i18nCell MsgTableTutorialTime) $ \res -> + let roomHidden = res ^. resultHideRoom + ttime = res ^. resultTutorial . _entityVal . _tutorialTime + in occurrencesCell roomHidden ttime , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo , sortable (Just "deregister-until") (i18nCell MsgTableTutorialDeregisterUntil) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialDeregisterUntil diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 81af8b6e4..7f0c0ff7c 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -445,7 +445,7 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do ^{userEmailWidget usr} |] , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom) - , sortable Nothing (i18nCell MsgTableTutorialTime) $ occurrencesCell . view (_dbrOutput . _1 . _entityVal . _tutorialTime) + , sortable Nothing (i18nCell MsgTableTutorialTime) $ occurrencesCell False . view (_dbrOutput . _1 . _entityVal . _tutorialTime) ] dbtSorting = mconcat [ singletonMap "type" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialType diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index ce1cb7a89..e906edd3f 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -29,18 +29,18 @@ getCTutorialListR tid ssh csh = do tutorialDBTable = DBTable{..} where resultTutorial :: Lens' (DBRow (Entity Tutorial, Int, Bool)) (Entity Tutorial) - resultTutorial = _dbrOutput . _1 + resultTutorial = _dbrOutput . _1 resultParticipants = _dbrOutput . _2 - resultShowRoom = _dbrOutput . _3 + resultHideRoom = _dbrOutput . _3 dbtSQLQuery tutorial = do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid let participants :: E.SqlExpr (E.Value Int) participants = E.subSelectCount . E.from $ \tutorialParticipant -> E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId - let showRoom = maybe E.false (flip showTutorialRoom tutorial . E.val) muid - E.||. E.not_ (tutorial E.^. TutorialRoomHidden) - return (tutorial, participants, showRoom) + let hideRoom = maybe E.true (E.not__ . flip showTutorialRoom tutorial . E.val) muid + E.&&. (tutorial E.^. TutorialRoomHidden) + return (tutorial, participants, hideRoom) dbtRowKey = (E.^. TutorialId) dbtProj = over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue <$> dbtProjId dbtColonnade = dbColonnade $ mconcat @@ -61,10 +61,13 @@ getCTutorialListR tid ssh csh = do |] , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \(view $ $(multifocusL 2) (resultTutorial . _entityVal) resultParticipants -> (Tutorial{..}, n)) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . tshow) tutorialCapacity - , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if - | res ^. resultShowRoom -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res + , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if -- TODO REMOVE + | res ^. resultHideRoom . _not -> cellMaybe roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res | otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text) - , sortable Nothing (i18nCell MsgTableTutorialTime) $ \(view $ resultTutorial . _entityVal . _tutorialTime -> ttime) -> occurrencesCell ttime + , sortable Nothing (i18nCell MsgTableTutorialTime) $ \res -> + let roomHidden = res ^. resultHideRoom + ttime = res ^. resultTutorial . _entityVal . _tutorialTime + in occurrencesCell roomHidden ttime , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . CI.original) tutorialRegGroup , sortable (Just "register-from") (i18nCell MsgRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo diff --git a/src/Handler/Utils/Form/Occurrences.hs b/src/Handler/Utils/Form/Occurrences.hs index 13d413c80..1fb134d58 100644 --- a/src/Handler/Utils/Form/Occurrences.hs +++ b/src/Handler/Utils/Form/Occurrences.hs @@ -8,6 +8,7 @@ module Handler.Utils.Form.Occurrences import Import import Handler.Utils.Form +import Handler.Utils.Widgets import Handler.Utils.DateTime import qualified Data.Set as Set @@ -60,6 +61,7 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do <$> apreq (selectField' Nothing optionsFinite) (fslI MsgOccurrenceWeekDay & addName (nudge "occur-week-day")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing + <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) Nothing ) ] ) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing @@ -96,6 +98,7 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do <$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing + <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) Nothing ) , ( ExceptionKindNoOccur , ExceptNoOccur diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index a4d8e7b14..3a5e511e1 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -19,6 +19,7 @@ import Utils.Holidays (isWeekend) import Utils.Occurrences import Handler.Utils.DateTime +import Handler.Utils.Widgets (roomReferenceWidget) -- import Text.Read (read) -- for DEBUGGING only @@ -34,15 +35,15 @@ data LessonTime = LessonTime { lessonStart, lessonEnd :: LocalTime } deriving (Eq, Ord, Read, Show, Generic) -- BEWARE: Ord instance might not be intuitive, but needed for Set occurringLessons :: Term -> Occurrences -> Set LessonTime -occurringLessons t Occurrences{..} = Set.union exceptOcc $ Set.filter isExcept scheduledLessons +occurringLessons term Occurrences{..} = Set.union exceptOcc $ Set.filter isExcept scheduledLessons where - scheduledLessons = occurrenceScheduleToLessons t `foldMap` occurrencesScheduled + scheduledLessons = occurrenceScheduleToLessons term `foldMap` occurrencesScheduled (exceptOcc, exceptNo) = occurrenceExceptionToLessons occurrencesExceptions isExcept LessonTime{lessonStart} = Set.notMember lessonStart exceptNo occurrenceScheduleToLessons :: Term -> OccurrenceSchedule -> Set LessonTime occurrenceScheduleToLessons Term{..} = - let setHolidays = Set.fromList termHolidays + let setHolidays = Set.fromList termHolidays -- ensure that the conversion is performed only once for repeated calls in \ScheduleWeekly{..} -> let occDays = daysOfWeekBetween (termLectureStart, termLectureEnd) scheduleDayOfWeek \\ setHolidays toLesson d = LessonTime { lessonStart = LocalTime d scheduleStart @@ -66,9 +67,8 @@ occurrenceExceptionToLessons = Set.foldr aux mempty -- Occurrences -- ----------------- - -occurrencesWidget :: JSONB Occurrences -> Widget -occurrencesWidget (normalizeOccurrences . unJSONB -> Occurrences{..}) = do +occurrencesWidget :: Bool -> JSONB Occurrences -> Widget +occurrencesWidget roomHidden (normalizeOccurrences . unJSONB -> Occurrences{..}) = do let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case ScheduleWeekly{..} -> do scheduleStart' <- formatTime SelFormatTime scheduleStart diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index dd5474df8..c5bddd475 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -48,10 +48,11 @@ addIndicatorCell = tellCell $ Any True writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w writerCell act = mempty & cellContents %~ (<* act) --- for documentation purposes +-- for documentation purposes and better error message cellMaybe :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b cellMaybe = foldMap +-- for documentation purposes and better error message maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b maybeCell = flip foldMap @@ -509,8 +510,8 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc -occurrencesCell :: IsDBTable m a => JSONB Occurrences -> DBCell m a -occurrencesCell = cell . occurrencesWidget +occurrencesCell :: IsDBTable m a => Bool -> JSONB Occurrences -> DBCell m a +occurrencesCell roomHidden occs = cell $ occurrencesWidget roomHidden occs roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a roomReferenceCell = cell . roomReferenceWidget diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index d1aaa7087..fc5c7bfc0 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -293,8 +293,8 @@ examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets roomReferenceWidget :: RoomReference -> Widget -roomReferenceWidget RoomReferenceSimple{..} = toWidget roomRefText -roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference/link") +roomReferenceWidget RoomReferenceSimple{..} = msg2widget $ MsgRoomReferenceSimpleAt roomRefText +roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference/link") where linkText = uriToString id roomRefLink mempty instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal") diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 6a3457783..55ec90530 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -14,6 +14,7 @@ module Model.Types.DateTime ) where import Import.NoModel +import Model.Types.Room -- import qualified Data.Set as Set import Data.Ratio ((%)) @@ -167,8 +168,9 @@ data OccurrenceSchedule = ScheduleWeekly { scheduleDayOfWeek :: WeekDay , scheduleStart :: TimeOfDay , scheduleEnd :: TimeOfDay + , scheduleRoom :: Maybe RoomReference } - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Show, Generic) deriving anyclass (NFData) deriveJSON defaultOptions @@ -182,11 +184,12 @@ data OccurrenceException = ExceptOccur { exceptDay :: Day , exceptStart :: TimeOfDay , exceptEnd :: TimeOfDay + , exceptRoom :: Maybe RoomReference -- ignored in Ord instance } | ExceptNoOccur { exceptTime :: LocalTime } - deriving (Eq, Read, Show, Generic) + deriving (Eq, Show, Generic) deriving anyclass (NFData) -- Handler.Utils.Occurrences.occurrencesAddBusinessDays assumes that OccurrenceException is ordered chronologically @@ -218,7 +221,7 @@ data Occurrences = Occurrences { occurrencesScheduled :: Set OccurrenceSchedule , occurrencesExceptions :: Set OccurrenceException } - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Show, Generic) deriving anyclass (NFData) deriveJSON defaultOptions @@ -256,10 +259,10 @@ nullaryPathPiece ''DayOfWeek camelToPathPiece -- yesterday = addUTCTime (negate nominalDay) now -- lt3 = utcToLocalTime tz yesterday -- pure --- [ ExceptOccur (utctDay tomorrow ) midday midnight --- , ExceptOccur (utctDay now ) midnight midnight --- , ExceptOccur (utctDay now ) midday midnight --- , ExceptOccur (utctDay yesterday) midday midnight +-- [ ExceptOccur (utctDay tomorrow ) midday midnight Nothing +-- , ExceptOccur (utctDay now ) midnight midnight Nothing +-- , ExceptOccur (utctDay now ) midday midnight Nothing +-- , ExceptOccur (utctDay yesterday) midday midnight Nothing -- , ExceptNoOccur lt3 -- , ExceptNoOccur lt1 -- , ExceptNoOccur lt2 diff --git a/src/Utils.hs b/src/Utils.hs index 35c15b39d..8392a176c 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -923,7 +923,14 @@ toNothing = const Nothing toNothingS :: String -> Maybe b toNothingS = const Nothing --- | change second of maybe pair to Nothing, if both are Just and equal +infix 4 ==~ + +-- | Equality treating `Nothing` as an always matching wildcard +(==~) :: Eq a => Maybe a -> Maybe a -> Bool +(==~) (Just x) (Just y) = x == y +(==~) _ _ = True + +-- | change second of maybe pair to `Nothing`, if both are `Just` and equal eq2nothing :: Eq a => (Maybe a, Maybe a) -> (Maybe a, Maybe a) eq2nothing (mx@(Just x), Just y) | x==y = (mx, Nothing) eq2nothing p = p diff --git a/src/Utils/Occurrences.hs b/src/Utils/Occurrences.hs index 31f654268..5d6f369b2 100644 --- a/src/Utils/Occurrences.hs +++ b/src/Utils/Occurrences.hs @@ -44,13 +44,15 @@ normalizeOccurrences initial let merge b@ScheduleWeekly{} | scheduleDayOfWeek a == scheduleDayOfWeek b -- b starts during a - , scheduleStart a <= scheduleStart b - , scheduleEnd a >= scheduleStart b - = Just $ ScheduleWeekly (scheduleDayOfWeek a) (scheduleStart a) ((max `on` scheduleEnd) a b) + , scheduleStart a <= scheduleStart b + , scheduleEnd a >= scheduleStart b + , scheduleRoom a ==~ scheduleRoom b + = Just $ ScheduleWeekly (scheduleDayOfWeek a) (scheduleStart a) ((max `on` scheduleEnd) a b) (scheduleRoom a <|> scheduleRoom b) | scheduleDayOfWeek a == scheduleDayOfWeek b -- b ends during a - , scheduleStart a <= scheduleEnd b - , scheduleEnd a >= scheduleEnd b - = Just $ ScheduleWeekly (scheduleDayOfWeek a) ((min `on` scheduleStart) a b) (scheduleEnd a) + , scheduleStart a <= scheduleEnd b + , scheduleEnd a >= scheduleEnd b + , scheduleRoom a ==~ scheduleRoom b + = Just $ ScheduleWeekly (scheduleDayOfWeek a) ((min `on` scheduleStart) a b) (scheduleEnd a) (scheduleRoom a <|> scheduleRoom b) | otherwise = Nothing merge _ = Nothing @@ -83,6 +85,7 @@ normalizeOccurrences initial [ scheduleDayOfWeek == localWeekDay , scheduleStart == exceptStart , scheduleEnd == exceptEnd + , scheduleRoom ==~ exceptRoom ] unless needed $ throwE =<< asks (over _occurrencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle) diff --git a/templates/course.hamlet b/templates/course.hamlet index 21fc03fa5..a9e75d4d6 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -255,7 +255,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) #{courseEventType}
    - ^{occurrencesWidget courseEventTime} + ^{occurrencesWidget (not showRoom) courseEventTime} $if showRoom
    diff --git a/templates/tutorial-participants.hamlet b/templates/tutorial-participants.hamlet index 0eae86644..ef2d80c93 100644 --- a/templates/tutorial-participants.hamlet +++ b/templates/tutorial-participants.hamlet @@ -8,7 +8,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
    _{MsgTableTutorialTime}
    - ^{occurrencesWidget tutorialTime} + ^{occurrencesWidget tutorialRoomHidden tutorialTime}
    _{MsgTableTutorialTutors}
      diff --git a/templates/widgets/occurrence/cell/except-no-occurr.hamlet b/templates/widgets/occurrence/cell/except-no-occurr.hamlet deleted file mode 100644 index 2addccf6b..000000000 --- a/templates/widgets/occurrence/cell/except-no-occurr.hamlet +++ /dev/null @@ -1,7 +0,0 @@ -$newline never - -$# SPDX-FileCopyrightText: 2022 Sarah Vaupel -$# -$# SPDX-License-Identifier: AGPL-3.0-or-later - -_{MsgExceptionKindNoOccur}: #{exceptTime'} diff --git a/templates/widgets/occurrence/cell/except-occur.hamlet b/templates/widgets/occurrence/cell/except-occur.hamlet index 5a9b48d35..f75f8f00c 100644 --- a/templates/widgets/occurrence/cell/except-occur.hamlet +++ b/templates/widgets/occurrence/cell/except-occur.hamlet @@ -5,6 +5,8 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later $if not (null occurrencesScheduled') - _{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'} + _{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'} + $if not roomHidden + ^{foldMap roomReferenceWidget exceptRoom} $else #{exceptStart'}–#{exceptEnd'} diff --git a/templates/widgets/occurrence/cell/except-occurr.hamlet b/templates/widgets/occurrence/cell/except-occurr.hamlet deleted file mode 100644 index 628c27f07..000000000 --- a/templates/widgets/occurrence/cell/except-occurr.hamlet +++ /dev/null @@ -1,7 +0,0 @@ -$newline never - -$# SPDX-FileCopyrightText: 2022 Sarah Vaupel -$# -$# SPDX-License-Identifier: AGPL-3.0-or-later - -_{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'} diff --git a/templates/widgets/occurrence/cell/weekly.hamlet b/templates/widgets/occurrence/cell/weekly.hamlet index 04c9ed456..c3893028e 100644 --- a/templates/widgets/occurrence/cell/weekly.hamlet +++ b/templates/widgets/occurrence/cell/weekly.hamlet @@ -4,4 +4,6 @@ $# SPDX-FileCopyrightText: 2022 Sarah Vaupel $# $# SPDX-License-Identifier: AGPL-3.0-or-later -_{ShortWeekDay scheduleDayOfWeek} #{scheduleStart'}–#{scheduleEnd'} +_{ShortWeekDay scheduleDayOfWeek} #{scheduleStart'}–#{scheduleEnd'} +$if not roomHidden + ^{foldMap roomReferenceWidget scheduleRoom} diff --git a/templates/widgets/occurrence/form/except-occur.hamlet b/templates/widgets/occurrence/form/except-occur.hamlet index 365b9f70b..4c1ee6e39 100644 --- a/templates/widgets/occurrence/form/except-occur.hamlet +++ b/templates/widgets/occurrence/form/except-occur.hamlet @@ -7,4 +7,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{ExceptionKindOccur} - #{exceptStart'}–#{exceptEnd'} + #{exceptStart'}–#{exceptEnd'} ^{foldMap roomReferenceWidget exceptRoom} diff --git a/templates/widgets/occurrence/form/weekly.hamlet b/templates/widgets/occurrence/form/weekly.hamlet index f28600fa0..5dee4e08c 100644 --- a/templates/widgets/occurrence/form/weekly.hamlet +++ b/templates/widgets/occurrence/form/weekly.hamlet @@ -7,4 +7,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{ScheduleKindWeekly} - _{scheduleDayOfWeek}, #{scheduleStart'}–#{scheduleEnd'} + _{scheduleDayOfWeek}, #{scheduleStart'}–#{scheduleEnd'} ^{foldMap roomReferenceWidget scheduleRoom} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index e30296c56..981d4794a 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1081,16 +1081,19 @@ fillDb = do { scheduleDayOfWeek = Thursday , scheduleStart = TimeOfDay 11 11 0 , scheduleEnd = TimeOfDay 12 22 0 + , scheduleRoom = Just $ RoomReferenceSimple "B777" } , ScheduleWeekly { scheduleDayOfWeek = Friday , scheduleStart = TimeOfDay 13 33 0 , scheduleEnd = TimeOfDay 14 44 0 + , scheduleRoom = Just $ RoomReferenceSimple "A320neo" } , ScheduleWeekly { scheduleDayOfWeek = Sunday , scheduleStart = TimeOfDay 15 55 0 , scheduleEnd = TimeOfDay 16 06 0 + , scheduleRoom = Nothing } ] , occurrencesExceptions = Set.fromList @@ -1098,16 +1101,19 @@ fillDb = do { exceptDay = nTimes 7 succ firstDay , exceptStart = TimeOfDay 8 30 0 , exceptEnd = TimeOfDay 16 0 0 + , exceptRoom = Just $ RoomReferenceSimple "A380" } , ExceptOccur { exceptDay = nTimes 8 succ secondDay , exceptStart = TimeOfDay 9 0 0 , exceptEnd = TimeOfDay 16 0 0 + , exceptRoom = Just $ RoomReferenceSimple "B747" } , ExceptOccur { exceptDay = nowaday , exceptStart = TimeOfDay 9 10 0 , exceptEnd = TimeOfDay 16 10 0 + , exceptRoom = Nothing } ] } @@ -1139,21 +1145,25 @@ fillDb = do { exceptDay = firstDay , exceptStart = TimeOfDay 8 30 0 , exceptEnd = TimeOfDay 16 0 0 + , exceptRoom = Nothing } , ExceptOccur { exceptDay = succ firstDay , exceptStart = TimeOfDay 9 0 0 , exceptEnd = TimeOfDay 16 0 0 + , exceptRoom = Nothing } , ExceptOccur { exceptDay = secondDay , exceptStart = TimeOfDay 10 12 0 , exceptEnd = TimeOfDay 12 13 0 + , exceptRoom = Nothing } , ExceptOccur { exceptDay = nowaday , exceptStart = TimeOfDay 17 10 0 , exceptEnd = TimeOfDay 18 10 0 + , exceptRoom = Nothing } ] } @@ -1184,16 +1194,19 @@ fillDb = do { exceptDay = succ $ succ firstDay , exceptStart = TimeOfDay 8 25 0 , exceptEnd = TimeOfDay 16 25 0 + , exceptRoom = Nothing } , ExceptOccur { exceptDay = succ $ succ $ succ $ succ firstDay , exceptStart = TimeOfDay 9 20 0 , exceptEnd = TimeOfDay 16 20 0 + , exceptRoom = Nothing } , ExceptOccur { exceptDay = succ $ succ secondDay , exceptStart = TimeOfDay 10 12 0 , exceptEnd = TimeOfDay 12 13 0 + , exceptRoom = Nothing } ] } From 22d6cf737ed4fd9d20dba763c32df4523250d0c6 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 30 Sep 2024 13:56:45 +0200 Subject: [PATCH 028/187] refactor(occurrences): remove RoomReference from model and add migration --- models/courses.model | 3 +- models/tutorials.model | 3 +- src/Handler/Course/Events/Delete.hs | 2 - src/Handler/Course/Events/Edit.hs | 1 - src/Handler/Course/Events/Form.hs | 4 - src/Handler/Course/Events/New.hs | 1 - src/Handler/Course/ParticipantInvite.hs | 3 +- src/Handler/Course/Show.hs | 4 - src/Handler/Course/User.hs | 2 - src/Handler/Tutorial/Edit.hs | 2 - src/Handler/Tutorial/Form.hs | 2 - src/Handler/Tutorial/List.hs | 4 - src/Handler/Tutorial/New.hs | 1 - src/Handler/Utils/Form/Occurrences.hs | 6 +- src/Model/Migration/Definitions.hs | 139 ++++++++++++++---- templates/course.hamlet | 14 +- .../widgets/occurrence/cell/weekly.hamlet | 6 +- test/Database/Fill.hs | 25 +--- 18 files changed, 127 insertions(+), 95 deletions(-) diff --git a/models/courses.model b/models/courses.model index 5f9702b55..594bbf48e 100644 --- a/models/courses.model +++ b/models/courses.model @@ -29,8 +29,7 @@ Course -- Information about a single course; contained info is always visible deriving Generic CourseEvent type (CI Text) - course CourseId OnDeleteCascade OnUpdateCascade - room RoomReference Maybe + course CourseId OnDeleteCascade OnUpdateCascade roomHidden Bool default=false time (JSONB Occurrences) note StoredMarkup Maybe diff --git a/models/tutorials.model b/models/tutorials.model index 173f7862c..72dc8676a 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -6,8 +6,7 @@ Tutorial json name TutorialName course CourseId OnDeleteCascade OnUpdateCascade type (CI Text) -- "Tutorium", "Zentralübung", ... - capacity Int Maybe -- limit for enrolment in this tutorial - room RoomReference Maybe + capacity Int Maybe -- limit for enrolment in this tutorial roomHidden Bool default=false time (JSONB Occurrences) regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup diff --git a/src/Handler/Course/Events/Delete.hs b/src/Handler/Course/Events/Delete.hs index 179be19bf..1931ff220 100644 --- a/src/Handler/Course/Events/Delete.hs +++ b/src/Handler/Course/Events/Delete.hs @@ -31,8 +31,6 @@ postCEvDeleteR tid ssh csh cID = do [whamlet| $newline never #{courseEventType} - $maybe room <- courseEventRoom - , #{roomReferenceText room} : ^{occurrencesWidget False courseEventTime} |] diff --git a/src/Handler/Course/Events/Edit.hs b/src/Handler/Course/Events/Edit.hs index b1af6858e..fc9901031 100644 --- a/src/Handler/Course/Events/Edit.hs +++ b/src/Handler/Course/Events/Edit.hs @@ -26,7 +26,6 @@ postCEvEditR tid ssh csh cID = do replace eId CourseEvent { courseEventCourse , courseEventType = cefType - , courseEventRoom = cefRoom , courseEventRoomHidden = cefRoomHidden , courseEventTime = cefTime & JSONB , courseEventNote = cefNote diff --git a/src/Handler/Course/Events/Form.hs b/src/Handler/Course/Events/Form.hs index 30eb8ec6c..c90a82bb4 100644 --- a/src/Handler/Course/Events/Form.hs +++ b/src/Handler/Course/Events/Form.hs @@ -17,7 +17,6 @@ import qualified Database.Esqueleto.Legacy as E data CourseEventForm = CourseEventForm { cefType :: CI Text - , cefRoom :: Maybe RoomReference , cefRoomHidden :: Bool , cefTime :: Occurrences , cefNote :: Maybe StoredMarkup @@ -37,14 +36,12 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar let courseEventTypes = optionsPairs [ (courseEventType, courseEventType) | Entity _ CourseEvent{..} <- existingEvents ] cefType' <- wreq (textField & cfStrip & cfCI & addDatalist courseEventTypes) (fslI MsgCourseEventType & addPlaceholder (mr MsgCourseEventTypePlaceholder)) (cefType <$> template) - cefRoom' <- aFormToWForm $ roomReferenceFormOpt (fslI MsgCourseEventRoom) (cefRoom <$> template) cefRoomHidden' <- wpopt checkBoxField (fslI MsgCourseEventRoomHidden & setTooltip MsgCourseEventRoomHiddenTip) (cefRoomHidden <$> template) cefTime' <- aFormToWForm $ occurrencesAForm ("time" :: Text) (cefTime <$> template) cefNote' <- wopt htmlField (fslI MsgCourseEventNote) (cefNote <$> template) return $ CourseEventForm <$> cefType' - <*> cefRoom' <*> cefRoomHidden' <*> cefTime' <*> cefNote' @@ -52,7 +49,6 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar courseEventToForm :: CourseEvent -> CourseEventForm courseEventToForm CourseEvent{..} = CourseEventForm { cefType = courseEventType - , cefRoom = courseEventRoom , cefRoomHidden = courseEventRoomHidden , cefTime = courseEventTime & unJSONB , cefNote = courseEventNote diff --git a/src/Handler/Course/Events/New.hs b/src/Handler/Course/Events/New.hs index 5c09e2931..8a57706d4 100644 --- a/src/Handler/Course/Events/New.hs +++ b/src/Handler/Course/Events/New.hs @@ -24,7 +24,6 @@ postCEventsNewR tid ssh csh = do eId <- insert CourseEvent { courseEventCourse = cid , courseEventType = cefType - , courseEventRoom = cefRoom , courseEventRoomHidden = cefRoomHidden , courseEventTime = cefTime & JSONB , courseEventNote = cefNote diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 538d4d68a..dfb456147 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel , Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -384,7 +384,6 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do , tutorialCourse = cid , tutorialType = fromMaybe defaultTutorialType newTutorialType , tutorialCapacity = Nothing - , tutorialRoom = Nothing , tutorialRoomHidden = False , tutorialTime = mempty , tutorialRegGroup = Nothing diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index a9ba08cbf..d211bcda5 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -180,9 +180,6 @@ getCShowR tid ssh csh = do
    • ^{nameEmailWidget' tutor} |] - , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if -- TODO REMOVE - | res ^. resultHideRoom . _not -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res - | otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text) , sortable Nothing (i18nCell MsgTableTutorialTime) $ \res -> let roomHidden = res ^. resultHideRoom ttime = res ^. resultTutorial . _entityVal . _tutorialTime @@ -223,7 +220,6 @@ getCShowR tid ssh csh = do [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType ) , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName ) , ("first-day", SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialFirstDay ) - , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom ) , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom ) , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo ) , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil ) diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 7f0c0ff7c..2d2d221c2 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -444,13 +444,11 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
    • ^{userEmailWidget usr} |] - , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom) , sortable Nothing (i18nCell MsgTableTutorialTime) $ occurrencesCell False . view (_dbrOutput . _1 . _entityVal . _tutorialTime) ] dbtSorting = mconcat [ singletonMap "type" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialType , singletonMap "name" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialName - , singletonMap "room" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialRoom , singletonMap "tutors" . SortColumn $ \(tutorial `E.InnerJoin` _) -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId E.where_ $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs index c13c88df0..cf6938ec6 100644 --- a/src/Handler/Tutorial/Edit.hs +++ b/src/Handler/Tutorial/Edit.hs @@ -37,7 +37,6 @@ postTEditR tid ssh csh tutn = do { tfName = tutorialName , tfType = tutorialType , tfCapacity = tutorialCapacity - , tfRoom = tutorialRoom , tfRoomHidden = tutorialRoomHidden , tfTime = tutorialTime & unJSONB , tfRegGroup = tutorialRegGroup @@ -62,7 +61,6 @@ postTEditR tid ssh csh tutn = do , tutorialCourse = cid , tutorialType = tfType , tutorialCapacity = tfCapacity - , tutorialRoom = tfRoom , tutorialRoomHidden = tfRoomHidden , tutorialTime = tfTime & JSONB , tutorialRegGroup = tfRegGroup diff --git a/src/Handler/Tutorial/Form.hs b/src/Handler/Tutorial/Form.hs index 8c4743ea2..f5fda2d55 100644 --- a/src/Handler/Tutorial/Form.hs +++ b/src/Handler/Tutorial/Form.hs @@ -25,7 +25,6 @@ data TutorialForm = TutorialForm , tfRegGroup :: Maybe (CI Text) , tfTutorControlled :: Bool , tfCapacity :: Maybe Int - , tfRoom :: Maybe RoomReference , tfRoomHidden :: Bool , tfTime :: Occurrences , tfRegisterFrom :: Maybe UTCTime @@ -75,7 +74,6 @@ tutorialForm cid template html = do <*> aopt (textField & cfStrip & cfCI) (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial")) <*> apopt checkBoxField (fslI MsgTutorialTutorControlled & setTooltip MsgTutorialTutorControlledTip) (tfTutorControlled <$> template) <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template) - <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) (tfRoom <$> template) <*> apopt checkBoxField (fslI MsgTableTutorialRoomHidden & setTooltip MsgTutorialRoomHiddenTip) (tfRoomHidden <$> template <|> Just False) <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template) <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgTutorialDate) diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index e906edd3f..a628215c2 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -61,9 +61,6 @@ getCTutorialListR tid ssh csh = do |] , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \(view $ $(multifocusL 2) (resultTutorial . _entityVal) resultParticipants -> (Tutorial{..}, n)) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . tshow) tutorialCapacity - , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if -- TODO REMOVE - | res ^. resultHideRoom . _not -> cellMaybe roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res - | otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text) , sortable Nothing (i18nCell MsgTableTutorialTime) $ \res -> let roomHidden = res ^. resultHideRoom ttime = res ^. resultTutorial . _entityVal . _tutorialTime @@ -92,7 +89,6 @@ getCTutorialListR tid ssh csh = do in participantCount ) , ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity ) - , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom ) , ("register-group", SortColumn $ \tutorial -> tutorial E.^. TutorialRegGroup ) , ("register-from" , SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialRegisterFrom ) , ("register-to" , SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialRegisterTo ) diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index 50508ae68..34ccbdab4 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -33,7 +33,6 @@ postCTutorialNewR tid ssh csh = do , tutorialCourse = cid , tutorialType = tfType , tutorialCapacity = tfCapacity - , tutorialRoom = tfRoom , tutorialRoomHidden = tfRoomHidden , tutorialTime = JSONB tfTime , tutorialRegGroup = tfRegGroup diff --git a/src/Handler/Utils/Form/Occurrences.hs b/src/Handler/Utils/Form/Occurrences.hs index 1fb134d58..767b9f5c7 100644 --- a/src/Handler/Utils/Form/Occurrences.hs +++ b/src/Handler/Utils/Form/Occurrences.hs @@ -61,7 +61,9 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do <$> apreq (selectField' Nothing optionsFinite) (fslI MsgOccurrenceWeekDay & addName (nudge "occur-week-day")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing - <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) Nothing + -- DEBUG TODO + -- <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) Nothing + <*> pure Nothing ) ] ) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing @@ -98,7 +100,9 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do <$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing + -- DEBUG TODO <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) Nothing + -- <*> pure Nothing ) , ( ExceptionKindNoOccur , ExceptNoOccur diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 6a0f3eb4b..9d5dec086 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -48,9 +48,10 @@ import qualified Data.Time.Zones as TZ data ManualMigration = Migration20230524QualificationUserBlock - | Migration20230703LmsUserStatus + | Migration20230703LmsUserStatus | Migration20240212InitInterfaceHealth -- create table interface_health and fill with default values - | Migration20240224UniquenessCompanyAvsNr + | Migration20240224UniquenessCompanyAvsNr + | Migration20240930RoomOccurrences -- rooms become a part of occurrences deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) @@ -89,16 +90,16 @@ migrateManual = do , ("study_features_relevance_cached", "CREATE INDEX study_features_relevance_cached ON \"study_features\" (relevance_cached)") , ("submission_rating_by", "CREATE INDEX submission_rating_by ON submission (rating_by) WHERE rating_by IS NOT NULL" ) , ("exam_corrector_user", "CREATE INDEX exam_corrector_user ON exam_corrector (\"user\")" ) - , ("submission_rating_time", "CREATE INDEX submission_rating_time ON submission (rating_time)" ) + , ("submission_rating_time", "CREATE INDEX submission_rating_time ON submission (rating_time)" ) , ("idx_qualification_user_first_held" ,"CREATE INDEX idx_qualification_user_first_held ON \"qualification_user\" (\"first_held\")") , ("idx_qualification_user_valid_until" ,"CREATE INDEX idx_qualification_user_valid_until ON \"qualification_user\" (\"valid_until\")") , ("idx_qualification_user_block_quser" ,"CREATE INDEX idx_qualification_user_block_quser ON \"qualification_user_block\" (\"qualification_user\")") , ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")") - , ("idx_qualification_user_block_from" ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")") - , ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")") + , ("idx_qualification_user_block_from" ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")") + , ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")") , ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")") , ("idx_user_company_company" ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company - , ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user + , ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user ] where addIndex :: Text -> Sql -> Migration @@ -142,17 +143,17 @@ customMigrations = mapF $ \case Migration20230524QualificationUserBlock -> whenM (andM [ not <$> tableExists "qualification_user_block" - , tableExists "qualification_user" - , columnExists "qualification_user" "blocked_due" + , tableExists "qualification_user" + , columnExists "qualification_user" "blocked_due" ] ) $ do [executeQQ| - CREATE TABLE "qualification_user_block" + CREATE TABLE "qualification_user_block" ( "id" SERIAL8 PRIMARY KEY UNIQUE , "qualification_user" bigint NOT NULL , "unblock" boolean NOT NULL , "from" timestamp with time zone NOT NULL , "reason" character varying NOT NULL - , "blocker" bigint + , "blocker" bigint , CONSTRAINT qualification_user_block_qualification_user_fkey FOREIGN KEY ("qualification_user") REFERENCES "qualification_user"(id) ON DELETE CASCADE ON UPDATE CASCADE , CONSTRAINT qualification_user_block_blocker_fkey FOREIGN KEY ("blocker") REFERENCES "user"(id) ); @@ -175,27 +176,27 @@ customMigrations = mapF $ \case UPDATE "lms_user" SET "status_day" = CAST("status"->>'day' AS date) , "status" = "status"->'lms-status' - ; + ; |] Migration20240212InitInterfaceHealth -> unlessM (tableExists "interface_health") $ do -- fill health table with some defaults [executeQQ| CREATE TABLE "interface_health" - ( id BIGSERIAL NOT NULL - , interface CHARACTER VARYING NOT NULL - , subtype CHARACTER VARYING - , write BOOLEAN - , hours BIGINT NOT NULL - , PRIMARY KEY(id) - , CONSTRAINT unique_interface_health UNIQUE(interface, subtype, write) - ); - INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") - VALUES - ('Printer', 'Acknowledge', True, 168) - , ('AVS' , 'Synch' , True , 96) - ON CONFLICT DO NOTHING; - |] + ( id BIGSERIAL NOT NULL + , interface CHARACTER VARYING NOT NULL + , subtype CHARACTER VARYING + , write BOOLEAN + , hours BIGINT NOT NULL + , PRIMARY KEY(id) + , CONSTRAINT unique_interface_health UNIQUE(interface, subtype, write) + ); + INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") + VALUES + ('Printer', 'Acknowledge', True, 168) + , ('AVS' , 'Synch' , True , 96) + ON CONFLICT DO NOTHING; + |] Migration20240224UniquenessCompanyAvsNr -> whenM (tableExists "company" `and2M` notM (indexExists "unique_company_avs_id")) $ do -- companies with avs_id == 0 can be deleted; company users are deleted automatically by cascade @@ -204,6 +205,81 @@ customMigrations = mapF $ \case ALTER TABLE "company" DROP CONSTRAINT IF EXISTS "unique_company_shorthand"; |] + Migration20240930RoomOccurrences -> do + whenM (tableColumnExists "tutorial" "room") + [executeQQ| + WITH updated_scheduled AS ( + SELECT id + , jsonb_agg( + CASE + WHEN jsonb_exists(elem, 'room') THEN elem + ELSE jsonb_set(elem, '{room}', to_jsonb(t.room)) + END + ) AS new_scheduled + FROM tutorial AS t + CROSS JOIN jsonb_array_elements(t."time"->'scheduled') AS elem + GROUP BY t.id, t.room + ), updated_exceptions AS ( + SELECT id + , jsonb_agg( + CASE + WHEN jsonb_exists(elem, 'room') THEN elem + ELSE jsonb_set(elem, '{room}', to_jsonb(t.room)) + END + ) AS new_exceptions + FROM tutorial AS t + CROSS JOIN jsonb_array_elements(t."time"->'exceptions') AS elem + GROUP BY t.id, t.room + ) + UPDATE tutorial AS t + SET "time" = jsonb_set( + jsonb_set(t."time", '{scheduled}', us.new_scheduled), + '{exceptions}', ue.new_exceptions + ) + FROM updated_scheduled AS us JOIN updated_exceptions AS ue ON us.id = ue.id + WHERE t.id = us.id + ; + + ALTER TABLE "tutorial" DROP COLUMN "room"; + |] + + whenM (tableColumnExists "course_event" "room") + [executeQQ| + WITH updated_scheduled AS ( + SELECT id + , jsonb_agg( + CASE + WHEN jsonb_exists(elem, 'room') THEN elem + ELSE jsonb_set(elem, '{room}', to_jsonb(t.room)) + END + ) AS new_scheduled + FROM course_event AS t + CROSS JOIN jsonb_array_elements(t."time"->'scheduled') AS elem + GROUP BY t.id, t.room + ), updated_exceptions AS ( + SELECT id + , jsonb_agg( + CASE + WHEN jsonb_exists(elem, 'room') THEN elem + ELSE jsonb_set(elem, '{room}', to_jsonb(t.room)) + END + ) AS new_exceptions + FROM course_event AS t + CROSS JOIN jsonb_array_elements(t."time"->'exceptions') AS elem + GROUP BY t.id, t.room + ) + UPDATE course_event AS t + SET "time" = jsonb_set( + jsonb_set(t."time", '{scheduled}', us.new_scheduled), + '{exceptions}', ue.new_exceptions + ) + FROM updated_scheduled AS us JOIN updated_exceptions AS ue ON us.id = ue.id + WHERE t.id = us.id + ; + + ALTER TABLE "course_event" DROP COLUMN "room"; + |] + tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do @@ -232,15 +308,22 @@ tableDropEmpty table = whenM (tableExists table) $ do columnExists :: MonadIO m => Text -- ^ Table -> Text -- ^ Column - -> ReaderT SqlBackend m Bool -- BEWARE: use tablesExist beforehand!!! + -> ReaderT SqlBackend m Bool -- BEWARE: use tablesExist beforehand!!! columnExists table column = do haveColumn <- [sqlQQ|SELECT column_name FROM information_schema.columns WHERE table_name=#{table} and column_name=#{column};|] case haveColumn :: [Single PersistValue] of [_] -> return True _other -> return False +-- | checks table existence before checking column existence to avoid errors +tableColumnExists :: MonadIO m + => Text -- ^ Table + -> Text -- ^ Column + -> ReaderT SqlBackend m Bool +tableColumnExists table column = and2M (tableExists table) (columnExists table column) + -- | equivalent to andM [ tableExists, not <$> columnExists] -columnNotExists :: MonadIO m +columnNotExists :: MonadIO m => Text -- ^ Table -> Text -- ^ Column -> ReaderT SqlBackend m Bool @@ -248,7 +331,7 @@ columnNotExists table column = and2M (tableExists table) (not <$> columnExists t indexExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool indexExists ixName = do - res <- [sqlQQ|SELECT EXISTS (SELECT 1 FROM pg_indexes WHERE schemaname = current_schema() AND indexname = #{ixName})|] + res <- [sqlQQ|SELECT EXISTS (SELECT 1 FROM pg_indexes WHERE schemaname = current_schema() AND indexname = #{ixName})|] return $ case res of [Single e] -> e _other -> True diff --git a/templates/course.hamlet b/templates/course.hamlet index a9e75d4d6..123178fd6 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -239,8 +239,6 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) _{MsgCourseEventType} _{MsgCourseEventTime} - - _{MsgCourseEventRoom} _{MsgCourseEventNote} $if mayCreateEvents @@ -248,7 +246,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) _{MsgCourseEventActions} \ #{iconInvisible} - $forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventRoom, courseEventNote}, showRoom) <- events + $forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventNote}, showRoom) <- events toPathPiece cID}>
      @@ -256,16 +254,6 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
      ^{occurrencesWidget (not showRoom) courseEventTime} - - $if showRoom -
      - $maybe room <- courseEventRoom - ^{roomReferenceWidget room} - $nothing - _{MsgCourseEventRoomIsUnset} - $else -
      - _{MsgCourseEventRoomIsHidden}
      #{courseEventNote} diff --git a/templates/widgets/occurrence/cell/weekly.hamlet b/templates/widgets/occurrence/cell/weekly.hamlet index c3893028e..ddf8c59e2 100644 --- a/templates/widgets/occurrence/cell/weekly.hamlet +++ b/templates/widgets/occurrence/cell/weekly.hamlet @@ -1,9 +1,11 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Sarah Vaupel +$# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel , Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later _{ShortWeekDay scheduleDayOfWeek} #{scheduleStart'}–#{scheduleEnd'} -$if not roomHidden +$if roomHidden + _{MsgTableTutorialRoomIsHidden} +$else ^{foldMap roomReferenceWidget scheduleRoom} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 981d4794a..8d584195d 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1005,7 +1005,6 @@ fillDb = do firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight tyear = year tid - weekDay = dayOfWeek firstDay -- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight capacity = Just 8 mkName = CI.mk @@ -1068,12 +1067,6 @@ fillDb = do , tutorialCourse = c , tutorialType = "Schulung" , tutorialCapacity = capacity - , tutorialRoom = Just $ case weekDay of - Monday -> "A380" - Tuesday -> "B747" - Wednesday -> "MD11" - Thursday -> "A380" - _ -> "B777" , tutorialRoomHidden = False , tutorialTime = JSONB $ Occurrences { occurrencesScheduled = Set.fromList @@ -1131,12 +1124,6 @@ fillDb = do , tutorialCourse = c , tutorialType = "Vorlage" , tutorialCapacity = capacity - , tutorialRoom = Just $ case weekDay of - Monday -> "A380" - Tuesday -> "B747" - Wednesday -> "MD11" - Thursday -> "A380" - _ -> "B777" , tutorialRoomHidden = False , tutorialTime = JSONB $ Occurrences { occurrencesScheduled = Set.empty @@ -1180,13 +1167,7 @@ fillDb = do , tutorialCourse = c , tutorialType = "Vorlage_Sondertutorium" , tutorialCapacity = capacity - , tutorialRoom = Just $ case weekDay of - Monday -> "A380" - Tuesday -> "B747" - Wednesday -> "MD11" - Thursday -> "A380" - _ -> "B777" - , tutorialRoomHidden = False + , tutorialRoomHidden = True , tutorialTime = JSONB $ Occurrences { occurrencesScheduled = Set.empty , occurrencesExceptions = Set.fromList @@ -1194,13 +1175,13 @@ fillDb = do { exceptDay = succ $ succ firstDay , exceptStart = TimeOfDay 8 25 0 , exceptEnd = TimeOfDay 16 25 0 - , exceptRoom = Nothing + , exceptRoom = Just $ RoomReferenceSimple "E175" } , ExceptOccur { exceptDay = succ $ succ $ succ $ succ firstDay , exceptStart = TimeOfDay 9 20 0 , exceptEnd = TimeOfDay 16 20 0 - , exceptRoom = Nothing + , exceptRoom = Just $ RoomReferenceSimple "LJ45" } , ExceptOccur { exceptDay = succ $ succ secondDay From 9d26c1c171535fd1755e59f96a3780c3dd1e10c2 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 30 Sep 2024 16:05:33 +0200 Subject: [PATCH 029/187] refactor(occurrences): fix migration --- src/Model/Migration/Definitions.hs | 36 +++++++++++++++++------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 9d5dec086..0f45bda71 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -219,7 +219,13 @@ customMigrations = mapF $ \case FROM tutorial AS t CROSS JOIN jsonb_array_elements(t."time"->'scheduled') AS elem GROUP BY t.id, t.room - ), updated_exceptions AS ( + ) + UPDATE tutorial AS t + SET "time" = jsonb_set(t."time", '{scheduled}', us.new_scheduled) + FROM updated_scheduled AS us + WHERE t.id = us.id + ; + WITH updated_exceptions AS ( SELECT id , jsonb_agg( CASE @@ -232,14 +238,10 @@ customMigrations = mapF $ \case GROUP BY t.id, t.room ) UPDATE tutorial AS t - SET "time" = jsonb_set( - jsonb_set(t."time", '{scheduled}', us.new_scheduled), - '{exceptions}', ue.new_exceptions - ) - FROM updated_scheduled AS us JOIN updated_exceptions AS ue ON us.id = ue.id - WHERE t.id = us.id + SET "time" = jsonb_set(t."time", '{exceptions}', ue.new_exceptions) + FROM updated_exceptions AS ue + WHERE t.id = ue.id ; - ALTER TABLE "tutorial" DROP COLUMN "room"; |] @@ -256,7 +258,13 @@ customMigrations = mapF $ \case FROM course_event AS t CROSS JOIN jsonb_array_elements(t."time"->'scheduled') AS elem GROUP BY t.id, t.room - ), updated_exceptions AS ( + ) + UPDATE course_event AS t + SET "time" = jsonb_set(t."time", '{scheduled}', us.new_scheduled) + FROM updated_scheduled AS us + WHERE t.id = us.id + ; + WITH updated_exceptions AS ( SELECT id , jsonb_agg( CASE @@ -269,14 +277,10 @@ customMigrations = mapF $ \case GROUP BY t.id, t.room ) UPDATE course_event AS t - SET "time" = jsonb_set( - jsonb_set(t."time", '{scheduled}', us.new_scheduled), - '{exceptions}', ue.new_exceptions - ) - FROM updated_scheduled AS us JOIN updated_exceptions AS ue ON us.id = ue.id - WHERE t.id = us.id + SET "time" = jsonb_set(t."time", '{exceptions}', ue.new_exceptions) + FROM updated_exceptions AS ue + WHERE t.id = ue.id ; - ALTER TABLE "course_event" DROP COLUMN "room"; |] From 225af319437aabeb5a9b31f89bba2fbe3c654f49 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 2 Oct 2024 15:52:08 +0200 Subject: [PATCH 030/187] chore(occurrences): add GIN index for JSONB columns --- src/Handler/School/DayTasks.hs | 6 +++--- src/Model/Migration/Definitions.hs | 2 ++ 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 3bec3d289..5e6d8ba4e 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -43,6 +43,7 @@ data DailyTableActionData = DailyActDummyData deriving (Eq, Ord, Read, Show, Generic) -- | partial JSON object to be used for filtering with "@>" +-- ensure that a GIN index for the jsonb column is created in Model.Migration.Definitions occurrenceDayValue :: Day -> Value occurrenceDayValue d = Aeson.object [ "exceptions" Aeson..= @@ -50,7 +51,6 @@ occurrenceDayValue d = Aeson.object [ "exception" Aeson..= ("occur"::Text) , "day" Aeson..= d ] ] ] --- TODO: ensure that an appropriate GIN index for the jsonb column is set {- More efficient DB-only version, but ignores regular schedules getDayTutorials :: SchoolId -> Day -> DB [TutorialId] @@ -87,8 +87,8 @@ getDayTutorials ssh dlimit@(dstart, dend ) where period = Set.fromAscList [dstart..dend] - -- TODO: checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- common case - checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}},_) + checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- most common case + checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}, _) | not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ = Just tutId | otherwise diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 0f45bda71..6c7da942a 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -100,6 +100,8 @@ migrateManual = do , ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")") , ("idx_user_company_company" ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company , ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user + , ("idx_tutorial_time" ,"CREATE INDEX idx_tutorial_time ON \"tutorial\" USING GIN (\"time\")") -- GIN Index to speed up filtering with @>. + , ("idx_course_event_time" ,"CREATE INDEX idx_course_event_time ON \"course_event\" USING GIN (\"time\")") -- GIN Index to speed up filtering with @>. ] where addIndex :: Text -> Sql -> Migration From 2059d678ee90c5019a4248f3a6bbc3494abbb233 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 4 Oct 2024 12:19:27 +0200 Subject: [PATCH 031/187] refactor(memcached): remove ARC cache and LRU logic some more more leftover dead code was removed, especially cache prewarm options that no longer had an effect on a non-existing ARC cache --- config/settings.yml | 11 -- src/Application.hs | 10 -- src/Foundation/Type.hs | 4 - src/Handler/Utils/Files.hs | 41 ++----- src/Jobs.hs | 103 +++--------------- src/Jobs/Crontab.hs | 63 +---------- src/Jobs/Handler/Files.hs | 31 ++---- src/Jobs/Types.hs | 29 +---- src/Settings.hs | 37 ------- src/Utils.hs | 1 - src/Utils/LRU.hs | 217 ------------------------------------- src/Utils/Metrics.hs | 59 ---------- 12 files changed, 37 insertions(+), 569 deletions(-) delete mode 100644 src/Utils/LRU.hs diff --git a/config/settings.yml b/config/settings.yml index e5ae9c03f..582f6e640 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -317,17 +317,6 @@ fallback-personalised-sheet-files-keys-expire: 2419200 download-token-expire: 604801 -file-source-arc: - maximum-ghost: 512 - maximum-weight: 1073741824 # 1GiB -file-source-prewarm: - maximum-weight: 1073741824 # 1GiB - start: 1800 # 30m - end: 600 # 10m - inhibit: 3600 # 60m - steps: 20 - max-speedup: 3 - bot-mitigations: - only-logged-in-table-sorting - unauthorized-form-honeypots diff --git a/src/Application.hs b/src/Application.hs index 58156b47a..80662f3ed 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -115,8 +115,6 @@ import GHC.RTS.Flags (getRTSFlags) import qualified Prometheus -import qualified Data.IntervalMap.Strict as IntervalMap - import qualified Utils.Pool as Custom import qualified System.Clock as Clock @@ -216,14 +214,6 @@ makeFoundation appSettings''@AppSettings{..} = do appJobState <- liftIO newEmptyTMVarIO appHealthReport <- liftIO $ newTVarIO Set.empty - appFileSourcePrewarm <- for appFileSourcePrewarmConf $ \PrewarmCacheConf{..} -> do - lh <- initLRUHandle precMaximumWeight - void . Prometheus.register $ lruMetrics LRUFileSourcePrewarm lh - return lh - appFileInjectInhibit <- liftIO $ newTVarIO IntervalMap.empty - for_ (guardOnM (isn't _JobsOffload appJobMode) appInjectFiles) $ \_ -> - void . Prometheus.register $ injectInhibitMetrics appFileInjectInhibit - appStartTime <- liftIO getCurrentTime -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 9dbc9de50..7f6814ea7 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -30,8 +30,6 @@ import qualified Jose.Jwk as Jose import qualified Database.Memcached.Binary.IO as Memcached import Network.Minio (MinioConn) -import Data.IntervalMap.Strict (IntervalMap) - import qualified Utils.Pool as Custom import Utils.Metrics (DBConnUseState) @@ -84,8 +82,6 @@ data UniWorX = UniWorX , appUploadCache :: Maybe MinioConn , appVerpSecret :: VerpSecret , appAuthKey :: Auth.Key - , appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString) - , appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference)) , appPersonalisedSheetFilesSeedKey :: PersonalisedSheetFilesSeedKey , appVolatileClusterSettingsCache :: TVar VolatileClusterSettingsCache , appStartTime :: UTCTime -- for Status Page diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index a9de3f095..29cf40204 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -42,36 +42,17 @@ data SourceFilesException makePrisms ''SourceFilesException -fileChunk :: ( MonadHandler m - , HandlerSite m ~ UniWorX - ) - => (FileContentChunkReference, (Int, Int)) - -> m (Maybe (ByteString, Maybe FileChunkStorage)) +fileChunk :: ( MonadHandler m ) + => m (Maybe (ByteString, Maybe FileChunkStorage)) -> m (Maybe ByteString) -fileChunk k getChunkDB' = do - prewarm <- getsYesod appFileSourcePrewarm +fileChunk getChunkDB' = do -- NOTE: crude surgery happened here to remove ARC caching; useless artifacts may have remained - case prewarm of - Nothing -> do - chunk' <- getChunkDB' - for chunk' $ \(chunk, mStorage) -> chunk <$ do - $logDebugS "fileChunkARC" "No prewarm" - for_ mStorage $ \storage -> - let w = length chunk - in liftIO $ observeSourcedChunk storage w - Just lh -> do - chunkRes <- lookupLRUHandle lh k - case chunkRes of - Just (chunk, w) -> Just chunk <$ do - $logDebugS "fileChunkARC" "Prewarm hit" - liftIO $ observeSourcedChunk StoragePrewarm w - Nothing -> do - chunk' <- getChunkDB' - for chunk' $ \(chunk, mStorage) -> chunk <$ do - $logDebugS "fileChunkARC" "Prewarm miss" - for_ mStorage $ \storage -> - let w = length chunk - in liftIO $ observeSourcedChunk storage w + chunk' <- getChunkDB' + for chunk' $ \(chunk, mStorage) -> chunk <$ do + $logDebugS "fileChunkARC" "No prewarm" + for_ mStorage $ \storage -> + let w = length chunk + in liftIO $ observeSourcedChunk storage w sourceFileDB :: forall m. @@ -100,7 +81,7 @@ sourceFileChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlRe return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize) getChunkMinio = fmap (, StorageMinio) . catchIfMaybeT (is _SourceFilesContentUnavailable) . runConduit $ sourceMinio (Left chunkHash) (Just $ ByteRangeFromTo (fromIntegral $ pred start) (fromIntegral . pred $ pred start + dbChunksize)) .| C.fold in getChunkDB' <|> getChunkMinio - chunk <- fileChunk (chunkHash, (start, dbChunksize)) getChunkDB + chunk <- fileChunk getChunkDB case chunk of Just c | olength c <= 0 -> return Nothing Just c -> do @@ -232,7 +213,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectOne . E.from $ \fileContentChunk -> do E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize) - chunk <- fileChunk (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB + chunk <- fileChunk getChunkDB case chunk of Nothing -> throwM SourceFilesContentUnavailable Just c -> do diff --git a/src/Jobs.hs b/src/Jobs.hs index b45b24b82..2593260d4 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -18,7 +18,6 @@ import Jobs.Offload import Jobs.Crontab import qualified Data.Conduit.Combinators as C -import qualified Data.Conduit.List as C (mapMaybe) import qualified Data.Text.Lazy as LT @@ -52,15 +51,6 @@ import Control.Concurrent.STM.Delay import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay) -import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E - -import qualified Data.ByteString as ByteString - -import Handler.Utils.Files (sourceFileChunks, _SourceFilesContentUnavailable) - -import qualified Data.IntervalMap.Strict as IntervalMap - import Jobs.Handler.SendNotification import Jobs.Handler.SendTestEmail import Jobs.Handler.QueueNotification @@ -91,7 +81,7 @@ import Type.Reflection (typeOf) import System.Clock - + data JobQueueException = JInvalid QueuedJobId QueuedJob | JLocked QueuedJobId InstanceId UTCTime | JNonexistant QueuedJobId @@ -188,7 +178,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> let routeExc :: forall m'. Monad m' => (forall b. m b -> m b) -> m (m' ()) -> m (m' ()) routeExc unmask' = handleAll (\exc -> return () <$ throwTo me exc) . unmask' - + actAsync <- allocateLinkedAsyncWithUnmask $ \unmask' -> act (routeExc unmask') let handleExc e = do @@ -196,12 +186,12 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> atomically $ do jState <- tryReadTMVar appJobState for_ jState $ \JobState{jobShutdown} -> tryPutTMVar jobShutdown () - + void $ wait actAsync throwM e - + unmask (wait actAsync) `catchAll` handleExc - + num :: Int num = fromIntegral $ foundation ^. _appJobWorkers @@ -209,7 +199,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> spawnMissingWorkers = do shouldTerminate' <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown guard $ not shouldTerminate' - + oldState <- takeTMVar appJobState let missing = num - Map.size (jobWorkers oldState) guard $ missing > 0 @@ -266,7 +256,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!) go in go - + terminateGracefully :: (() -> ContT () m ()) -> STM (ContT () m ()) terminateGracefully terminate = do shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown @@ -329,7 +319,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> respawn <$ case cOffload of Nothing -> return () Just JobOffloadHandler{..} -> waitSTM jobOffloadHandler - + stopJobCtl :: MonadUnliftIO m => UniWorX -> m () -- ^ Stop all worker threads currently running @@ -388,7 +378,7 @@ execCrontab = do let doJob = mapRWST (liftHandler . runDBJobs) $ do -- newCrontab <- lift $ hoist lift determineCrontab' - -- when (newCrontab /= currentCrontab) $ + -- when (newCrontab /= currentCrontab) $ -- mapRWST (liftIO . atomically) $ -- liftBase . flip writeTVar newCrontab =<< asks (jobCrontab . jobContext) newCrontab <- liftIO . readTVarIO =<< asks (jobCrontab . jobContext) @@ -407,7 +397,7 @@ execCrontab = do case jobCtl of JobCtlQueue job -> lift $ queueDBJobCron job other -> runReaderT ?? foundation $ writeJobCtl other - + case nextMatch of MatchAsap -> doJob MatchNone -> return () @@ -497,7 +487,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker #endif , Exc.Handler $ \(e :: SomeException) -> return $ Left e ] . fmap Right - + handleQueueException :: MonadLogger m => JobQueueException -> m () handleQueueException (JInvalid jId j) = $logWarnS logIdent $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j handleQueueException (JNonexistant jId) = $logInfoS logIdent $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId) @@ -586,7 +576,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker liftHandler . runDB $ pruneLastExecs newCTab $logInfoS logIdent "PruneLastExecs" -- logDebugS logIdent $ tshow newCTab - mapReaderT (liftIO . atomically) $ + mapReaderT (liftIO . atomically) $ lift . flip writeTVar newCTab =<< asks jobCrontab handleCmd (JobCtlGenerateHealthReport kind) = do hrStorage <- getsYesod appHealthReport @@ -596,7 +586,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker $logInfoS logIdent [st|#{tshow kind}: #{toPathPiece newStatus}|] unless (newStatus > HealthFailure) $ do $logErrorS logIdent [st|#{tshow kind}: #{tshow newReport}|] - + liftIO $ do now <- getCurrentTime let updateReports = Set.insert (now, newReport) @@ -606,69 +596,6 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker $logInfoS logIdent [st|Sleeping #{tshow secs}s...|] threadDelay msecs $logInfoS logIdent [st|Slept #{tshow secs}s.|] - handleCmd JobCtlPrewarmCache{..} = do - prewarm <- getsYesod appFileSourcePrewarm - for_ prewarm $ \lh -> lift . runDBRead $ - runConduit $ sourceFileChunkIds .| C.map E.unValue - .| awaitForever (\cRef -> handleC handleUnavailable $ sourceFileChunks (withLRU lh cRef) cRef .| C.map (cRef, )) - .| C.mapM_ (sinkChunkCache lh) - where - handleUnavailable e - | is _SourceFilesContentUnavailable e = return () - | otherwise = throwM e - withLRU lh cRef range getChunk = do - touched <- touchLRUHandle lh (cRef, range) jcTargetTime - case touched of - Just (bs, _) -> return $ Just (bs, Nothing) - Nothing -> over (mapped . _2) Just <$> getChunk - (minBoundDgst, maxBoundDgst) = jcChunkInterval - sourceFileChunkIds = E.selectSource . E.from $ \fileContentEntry -> do - let cRef = fileContentEntry E.^. FileContentEntryChunkHash - eRef = fileContentEntry E.^. FileContentEntryHash - E.where_ . E.and $ catMaybes - [ minBoundDgst <&> \b -> cRef E.>=. E.val b - , maxBoundDgst <&> \b -> cRef E.<. E.val b - ] - E.where_ $ matchesPrewarmSource eRef jcPrewarmSource - return cRef - sinkChunkCache lh (cRef, (c, range)) = insertLRUHandle lh (cRef, range) jcTargetTime (c, ByteString.length c) - handleCmd JobCtlInhibitInject{..} = maybeT_ $ do - PrewarmCacheConf{..} <- MaybeT . getsYesod $ view _appFileSourcePrewarmConf - let inhibitInterval = IntervalMap.ClosedInterval - (addUTCTime (-precStart) jcTargetTime) - (addUTCTime (precInhibit - precStart) jcTargetTime) - sourceFileReferences = prewarmSourceReferences jcPrewarmSource - refs <- lift . lift . runDBRead . runConduit $ sourceFileReferences .| C.foldl (flip Set.insert) Set.empty - guard . not $ null refs - inhibitTVar <- getsYesod appFileInjectInhibit - atomically . modifyTVar' inhibitTVar $ force . IntervalMap.insertWith Set.union inhibitInterval refs - -matchesPrewarmSource :: E.SqlExpr (E.Value FileContentReference) -> JobCtlPrewarmSource -> E.SqlExpr (E.Value Bool) -matchesPrewarmSource eRef = \case - JobCtlPrewarmSheetFile{..} -> E.or - [ E.exists . E.from $ \sheetFile -> - E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val jcpsSheet - E.&&. sheetFile E.^. SheetFileType E.==. E.val jcpsSheetFileType - E.&&. sheetFile E.^. SheetFileContent E.==. E.just eRef - , E.exists . E.from $ \personalisedSheetFile -> - E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileSheet E.==. E.val jcpsSheet - E.&&. personalisedSheetFile E.^. PersonalisedSheetFileType E.==. E.val jcpsSheetFileType - E.&&. personalisedSheetFile E.^. PersonalisedSheetFileContent E.==. E.just eRef - ] - -prewarmSourceReferences :: JobCtlPrewarmSource -> ConduitT () FileContentReference (ReaderT SqlReadBackend (HandlerFor UniWorX)) () -prewarmSourceReferences = \case - JobCtlPrewarmSheetFile{..} -> (.| C.mapMaybe E.unValue) $ do - E.selectSource . E.from $ \sheetFile -> do - E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val jcpsSheet - E.&&. sheetFile E.^. SheetFileType E.==. E.val jcpsSheetFileType - E.where_ . E.isJust $ sheetFile E.^. SheetFileContent - return $ sheetFile E.^. SheetFileContent - E.selectSource . E.from $ \personalisedSheetFile -> do - E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileSheet E.==. E.val jcpsSheet - E.&&. personalisedSheetFile E.^. PersonalisedSheetFileType E.==. E.val jcpsSheetFileType - E.where_ . E.isJust $ personalisedSheetFile E.^. PersonalisedSheetFileContent - return $ personalisedSheetFile E.^. PersonalisedSheetFileContent jLocked :: QueuedJobId -> (Entity QueuedJob -> ReaderT JobContext Handler a) -> ReaderT JobContext Handler a jLocked jId act = flip evalStateT False $ do @@ -707,7 +634,7 @@ jLocked jId act = flip evalStateT False $ do update jId' [ QueuedJobLockInstance =. Nothing , QueuedJobLockTime =. Nothing ] - + bracket lock unlock $ lift . act @@ -723,7 +650,7 @@ pruneLastExecs crontab = do ensureCrontab (Entity leId CronLastExec{..}) = maybeT (return mempty) $ do now <- liftIO getCurrentTime flushInterval <- MaybeT . getsYesod . view $ appSettings . _appJobFlushInterval - + if | abs (now `diffUTCTime` cronLastExecTime) > flushInterval * 2 -> return mempty diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 9b76a0b00..27d621f9b 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -27,17 +27,6 @@ import qualified Data.Conduit.List as C import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E -import Jobs.Handler.Intervals.Utils - -import System.IO.Unsafe - -import Crypto.Hash (hashDigestSize, digestFromByteString) - -import Data.List (iterate) - -{-# NOINLINE prewarmCacheIntervalsCache #-} -prewarmCacheIntervalsCache :: TVar (Map Natural [(Maybe FileContentChunkReference, Maybe FileContentChunkReference)]) -prewarmCacheIntervalsCache = unsafePerformIO $ newTVarIO Map.empty determineCrontab :: ReaderT SqlReadBackend (HandlerFor UniWorX) (Crontab JobCtl) -- ^ Extract all future jobs from the database (sheet deadlines, ...) @@ -66,51 +55,9 @@ determineCrontab = execWriterT $ do } Nothing -> mempty - let - tellPrewarmJobs :: JobCtlPrewarmSource -> UTCTime -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) () - tellPrewarmJobs jcPrewarmSource jcTargetTime = maybeT_ $ do - PrewarmCacheConf{..} <- hoistMaybe appFileSourcePrewarmConf - - let - chunkHashBytes :: forall h. - ( Unwrapped FileContentChunkReference ~ Digest h ) - => Integer - chunkHashBytes = fromIntegral (hashDigestSize (error "hashDigestSize inspected argument" :: h)) - intervals <- mkIntervalsCached prewarmCacheIntervalsCache chunkHashBytes (fmap (review _Wrapped) . digestFromByteString) precSteps - - let step = realToFrac $ toRational (precStart - precEnd) / toRational precSteps - step' = realToFrac $ toRational step / precMaxSpeedup - - mapM_ tell - [ HashMap.singleton - JobCtlPrewarmCache{..} - Cron - { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ ts - , cronRepeat = CronRepeatOnChange - , cronRateLimit = step' - , cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ ts' - } - | jcChunkInterval <- intervals - | ts <- iterate (addUTCTime step) $ addUTCTime (-precStart) jcTargetTime - | ts' <- iterate (addUTCTime step') $ addUTCTime (subtract precStart . realToFrac $ toRational (precStart - precEnd) * (1 - recip precMaxSpeedup)) jcTargetTime - ] - - lift . maybeT_ $ do - injectInterval <- fmap abs . MaybeT . getsYesod $ view _appInjectFiles - tell $ HashMap.singleton - JobCtlInhibitInject{..} - Cron - { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime (negate $ precStart + injectInterval + 10) jcTargetTime - , cronRepeat = CronRepeatScheduled CronAsap - , cronRateLimit = injectInterval / 2 - , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime (precInhibit - precStart) jcTargetTime - } - let sheetJobs (Entity nSheet Sheet{..}) = do - for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom -> do - tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetExercise) aFrom - + for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom -> when (isn't _JobsOffload appJobMode) $ do tell $ HashMap.singleton (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..}) @@ -120,9 +67,7 @@ determineCrontab = execWriterT $ do , cronRateLimit = appNotificationRateLimit , cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) sheetActiveTo } - for_ (max <$> sheetVisibleFrom <*> sheetHintFrom) $ \hFrom -> do - tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetHint) hFrom - + for_ (max <$> sheetVisibleFrom <*> sheetHintFrom) $ \hFrom -> when (isn't _JobsOffload appJobMode) . maybeT_ $ do guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom hFrom) > 300) sheetActiveFrom guardM $ or2M (return $ maybe True (\sFrom -> abs (diffUTCTime sFrom hFrom) > 300) sheetSolutionFrom) @@ -136,9 +81,7 @@ determineCrontab = execWriterT $ do , cronRateLimit = appNotificationRateLimit , cronNotAfter = maybe (Left appNotificationExpiration) (Right . CronTimestamp . utcToLocalTimeTZ appTZ) sheetActiveTo } - for_ (max <$> sheetVisibleFrom <*> sheetSolutionFrom) $ \sFrom -> do - tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetSolution) sFrom - + for_ (max <$> sheetVisibleFrom <*> sheetSolutionFrom) $ \sFrom -> when (isn't _JobsOffload appJobMode) . maybeT_ $ do guard $ maybe True (\aFrom -> abs (diffUTCTime aFrom sFrom) > 300) sheetActiveFrom guardM . lift . lift $ exists [SheetFileType ==. SheetSolution, SheetFileSheet ==. nSheet] diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index 158a92f47..94370e9f8 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -44,13 +44,6 @@ import qualified Data.Sequence as Seq import Jobs.Handler.Intervals.Utils -import Data.IntervalMap.Strict (IntervalMap) -import qualified Data.IntervalMap.Strict as IntervalMap - -import Control.Concurrent.STM.TVar (stateTVar) - -import qualified Data.Foldable as F - import qualified Control.Monad.State.Class as State import Jobs.Types @@ -96,7 +89,7 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin missingDb <- runConduit . execStateC Map.empty $ do let insertRef refKind ref = State.modify' $ Map.alter (Just . Set.insert ref . fromMaybe Set.empty) refKind - + iforM_ trackedReferences $ \refKind refQuery -> do let fileReferencesQuery = do ref <- refQuery @@ -152,7 +145,7 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin , (''SubmissionFile, E.from $ \subFile -> return $ subFile E.^. SubmissionFileContent ) , (''SessionFile, E.from $ \sessFile -> return $ sessFile E.^. SessionFileContent ) ] - + {-# NOINLINE pruneUnreferencedFilesIntervalsCache #-} @@ -208,12 +201,12 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom let unreferencedChunkHash = E.unKey $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash - return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs + return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs E.where_ $ chunkIdFilter unreferencedChunkHash unmarkRefSource refSource = runConduit $ refSource .| C.map Seq.singleton .| C.chunksOfE chunkSize .| C.mapM_ unmarkSourceFiles chunkSize = 100 unmarkRefSource jobFileReferences - + let getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do let unreferencedSince = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunkUnreferenced) -> do @@ -277,16 +270,7 @@ dispatchJobInjectFiles :: JobHandler UniWorX dispatchJobInjectFiles = JobHandlerException . maybeT_ $ do uploadBucket <- getsYesod $ view _appUploadCacheBucket interval <- getsYesod $ view _appInjectFiles - - now <- liftIO getCurrentTime - let - extractInhibited :: IntervalMap UTCTime (Set FileContentReference) - -> (Set FileContentReference, IntervalMap UTCTime (Set FileContentReference)) - extractInhibited cState = (F.fold current, IntervalMap.union current upcoming) - where - (_, current, upcoming) = IntervalMap.splitIntersecting cState $ IntervalMap.OpenInterval (addUTCTime (-2) now) (addUTCTime 2 now) - inhibited <- atomically . flip stateTVar extractInhibited =<< getsYesod appFileInjectInhibit - + -- NOTE: crude surgery happened here to remove ARC caching; useless artifacts may have remained let extractReference (Minio.ListItemObject oi) = (oi, ) <$> Minio.oiObject oi ^? minioFileReference extractReference _ = Nothing @@ -296,7 +280,7 @@ dispatchJobInjectFiles = JobHandlerException . maybeT_ $ do injectOrDelete (objInfo, fRef) = do let obj = Minio.oiObject objInfo sz = fromIntegral $ max 1 $ Minio.oiSize objInfo - + fRef' <- runDB $ do logger <- askLoggerIO @@ -352,7 +336,6 @@ dispatchJobInjectFiles = JobHandlerException . maybeT_ $ do (Sum injectedFiles, Sum injectedSize) <- runConduit $ transPipe runAppMinio (Minio.listObjects uploadBucket Nothing True) .| C.mapMaybe extractReference - .| C.filter (views _2 (`Set.notMember` inhibited)) .| maybe (C.map id) (takeWhileTime . (/ 2)) interval .| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize) .| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFilesCount $ const 1) @@ -368,7 +351,7 @@ data RechunkFileException { oldHash, newHash :: FileContentReference } deriving (Eq, Ord, Show, Generic) deriving anyclass (Exception) - + dispatchJobRechunkFiles :: JobHandler UniWorX dispatchJobRechunkFiles = JobHandlerAtomicWithFinalizer act fin where diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 77e27c963..e1eaa1de3 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -9,8 +9,7 @@ module Jobs.Types ( Job(..), Notification(..) , JobChildren , classifyJob - , JobCtlPrewarmSource(..), _jcpsSheet, _jcpsSheetFileType - , JobCtl(..), _jcPrewarmSource, _jcChunkInterval + , JobCtl(..) , classifyJobCtl , YesodJobDB , JobHandler(..), _JobHandlerAtomic, _JobHandlerException @@ -218,34 +217,8 @@ classifyJob job = unpack tag Aeson.String tag = obj HashMap.! "job" -data JobCtlPrewarmSource - = JobCtlPrewarmSheetFile - { jcpsSheet :: SheetId - , jcpsSheetFileType :: SheetFileType - } - deriving (Eq, Ord, Read, Show, Generic) - deriving anyclass (Hashable, NFData) - -makeLenses_ ''JobCtlPrewarmSource - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 3 - , fieldLabelModifier = camelToPathPiece' 1 - , tagSingleConstructors = True - , sumEncoding = TaggedObject "source" "data" - } ''JobCtlPrewarmSource - data JobCtl = JobCtlFlush | JobCtlPerform QueuedJobId - | JobCtlPrewarmCache - { jcPrewarmSource :: JobCtlPrewarmSource - , jcTargetTime :: UTCTime - , jcChunkInterval :: (Maybe FileContentChunkReference, Maybe FileContentChunkReference) - } - | JobCtlInhibitInject - { jcPrewarmSource :: JobCtlPrewarmSource - , jcTargetTime :: UTCTime - } | JobCtlDetermineCrontab | JobCtlQueue Job | JobCtlGenerateHealthReport HealthCheck diff --git a/src/Settings.hs b/src/Settings.hs index 800c3deea..a16fbdbf4 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -238,9 +238,6 @@ data AppSettings = AppSettings , appJobLmsQualificationsEnqueueHour :: Maybe Natural , appJobLmsQualificationsDequeueHour :: Maybe Natural - , appFileSourceARCConf :: Maybe (ARCConf Int) - , appFileSourcePrewarmConf :: Maybe PrewarmCacheConf - , appBotMitigations :: Set SettingBotMitigation , appVolatileClusterSettingsCacheTime :: DiffTime @@ -420,18 +417,6 @@ data VerpMode = VerpNone | Verp { verpPrefix :: Text, verpSeparator :: Char } deriving (Eq, Show, Read, Generic) -data ARCConf w = ARCConf - { arccMaximumGhost :: Int - , arccMaximumWeight :: w - } deriving (Eq, Ord, Read, Show, Generic) - -data PrewarmCacheConf = PrewarmCacheConf - { precMaximumWeight :: Int - , precStart, precEnd, precInhibit :: NominalDiffTime -- ^ Prewarming cache starts at @t - precStart@ and should be finished by @t - precEnd@; injecting from minio to database is inhibited from @t - precStart@ until @t - precStart + precInhibit@ - , precSteps :: Natural - , precMaxSpeedup :: Rational - } deriving (Eq, Ord, Read, Show, Generic) - data SettingBotMitigation = SettingBotMitigationOnlyLoggedInTableSorting | SettingBotMitigationUnauthorizedFormHoneypots @@ -475,16 +460,6 @@ deriveJSON defaultOptions , constructorTagModifier = camelToPathPiece' 1 } ''JobMode -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''ARCConf - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''PrewarmCacheConf - -makeLenses_ ''PrewarmCacheConf - nullaryPathPiece ''SettingBotMitigation $ camelToPathPiece' 3 pathPieceJSON ''SettingBotMitigation pathPieceJSONKey ''SettingBotMitigation @@ -823,17 +798,6 @@ instance FromJSON AppSettings where appJobLmsQualificationsEnqueueHour <- o .:? "job-lms-qualifications-enqueue-hour" appJobLmsQualificationsDequeueHour <- o .:? "job-lms-qualifications-dequeue-hour" - appFileSourceARCConf <- assertM isValidARCConf <$> o .:? "file-source-arc" - - let isValidPrewarmConf PrewarmCacheConf{..} = and - [ precMaximumWeight > 0 - , precStart >= 0 - , precEnd >= 0, precEnd <= precStart - , precSteps > 0 - , precMaxSpeedup >= 1 - ] - appFileSourcePrewarmConf <- over (_Just . _precInhibit) (max 0) . assertM isValidPrewarmConf <$> o .:? "file-source-prewarm" - appBotMitigations <- o .:? "bot-mitigations" .!= Set.empty appVolatileClusterSettingsCacheTime <- o .: "volatile-cluster-settings-cache-time" @@ -846,7 +810,6 @@ instance FromJSON AppSettings where appLegalExternal <- o .: "legal-external" return AppSettings{..} - where isValidARCConf ARCConf{..} = arccMaximumWeight > 0 makeClassy_ ''AppSettings diff --git a/src/Utils.hs b/src/Utils.hs index 8392a176c..821da0d7b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -44,7 +44,6 @@ import Utils.I18n as Utils import Utils.NTop as Utils import Utils.HttpConditional as Utils import Utils.Persist as Utils -import Utils.LRU as Utils import Utils.Set as Utils import Text.Blaze (Markup, ToMarkup(..)) diff --git a/src/Utils/LRU.hs b/src/Utils/LRU.hs deleted file mode 100644 index 66517d70d..000000000 --- a/src/Utils/LRU.hs +++ /dev/null @@ -1,217 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -module Utils.LRU - ( LRUTick - , LRU, initLRU - , insertLRU, lookupLRU, touchLRU, timeoutLRU - , LRUHandle, initLRUHandle - , insertLRUHandle, lookupLRUHandle, touchLRUHandle, timeoutLRUHandle - , readLRUHandle - , lruStoreSize - , getLRUWeight - , describeLRU - ) where - -import ClassyPrelude - -import Data.OrdPSQ (OrdPSQ) -import qualified Data.OrdPSQ as OrdPSQ - -import Control.Lens - --- https://jaspervdj.be/posts/2015-02-24-lru-cache.html - - -newtype LRUTick = LRUTick { _getLRUTick :: Word64 } - deriving (Eq, Ord, Show) - deriving newtype (NFData) - -makeLenses ''LRUTick - -data LRU k t w v = LRU - { lruStore :: !(OrdPSQ k (t, LRUTick) (v, w)) - , lruWeight :: !w - , lruMaximumWeight :: !w - } - -instance (NFData k, NFData t, NFData w, NFData v) => NFData (LRU k t w v) where - rnf LRU{..} = rnf lruStore - `seq` rnf lruWeight - `seq` rnf lruMaximumWeight - -describeLRU :: Show w - => LRU k t w v - -> String -describeLRU LRU{..} = intercalate ", " - [ "lruStore: " <> show (OrdPSQ.size lruStore) - , "lruWeight: " <> show lruWeight - , "lruMaximumWeight: " <> show lruMaximumWeight - ] - -lruStoreSize :: LRU k t w v -> Int -lruStoreSize = OrdPSQ.size . lruStore - -getLRUWeight :: LRU k t w v -> w -getLRUWeight = lruWeight - -initialLRUTick, maximumLRUTick :: LRUTick -initialLRUTick = LRUTick 0 -maximumLRUTick = LRUTick maxBound - -initLRU :: forall k t w v. - Integral w - => w -- ^ @lruMaximumWeight@ - -> (LRU k t w v, LRUTick) -initLRU lruMaximumWeight - | lruMaximumWeight < 0 = error "initLRU given negative maximum weight" - | otherwise = (lru, initialLRUTick) - where lru = LRU { lruStore = OrdPSQ.empty - , lruWeight = 0 - , lruMaximumWeight - } - -insertLRU :: forall k t w v. - ( Ord k, Ord t - , Integral w - ) - => k - -> t - -> Maybe (v, w) - -> LRU k t w v - -> LRUTick -> (LRU k t w v, LRUTick) -insertLRU k t newVal oldLRU@LRU{..} now - | later <= initialLRUTick = uncurry (insertLRU k t newVal) $ initLRU lruMaximumWeight - | Just (_, w) <- newVal, w > lruMaximumWeight = (oldLRU, now) - | Just (_, w) <- newVal = (, later) $ - let (lruStore', lruWeight') = evictToSize (lruMaximumWeight - w) lruStore lruWeight - (fromMaybe 0 . preview (_Just . _2 . _2) -> oldWeight, lruStore'') - = OrdPSQ.alter (, ((t, now), ) <$> newVal) k lruStore' - in oldLRU { lruStore = lruStore'' - , lruWeight = lruWeight' - oldWeight + w - } - | Just (_, (_, w), lruStore') <- OrdPSQ.deleteView k lruStore = - let lru = oldLRU { lruStore = lruStore' - , lruWeight = lruWeight - w - } - in (lru, now) - | otherwise = (oldLRU, now) - where - later :: LRUTick - later = over getLRUTick succ now - - evictToSize :: w -> OrdPSQ k (t, LRUTick) (v, w) -> w -> (OrdPSQ k (t, LRUTick) (v, w), w) - evictToSize tSize c cSize - | cSize <= tSize = (c, cSize) - | Just (_, _, (_, w'), c') <- OrdPSQ.minView c = evictToSize tSize c' (cSize - w') - | otherwise = error "evictToSize: cannot reach required size through eviction" - -lookupLRU :: forall k t w v. - Ord k - => k - -> LRU k t w v - -> Maybe (v, w) -lookupLRU k LRU{..} = view _2 <$> OrdPSQ.lookup k lruStore - -touchLRU :: forall k t w v. - ( Ord k, Ord t - , Integral w - ) - => k - -> t - -> LRU k t w v - -> LRUTick -> ((LRU k t w v, LRUTick), Maybe (v, w)) -touchLRU k t oldLRU@LRU{..} now - | (Just (_, v), _) <- altered - , later <= initialLRUTick = (, Just v) . uncurry (insertLRU k t $ Just v) $ initLRU lruMaximumWeight - | (Just (_, v), lruStore') <- altered = ((oldLRU{ lruStore = lruStore' }, later), Just v) - | otherwise = ((oldLRU, now), Nothing) - where - altered = OrdPSQ.alter (\oldVal -> (oldVal, over _1 (max (t, later)) <$> oldVal)) k lruStore - - later :: LRUTick - later = over getLRUTick succ now - -timeoutLRU :: forall k t w v. - ( Ord k, Ord t - , Integral w - ) - => t - -> LRU k t w v - -> LRU k t w v -timeoutLRU t oldLRU@LRU{..} = oldLRU - { lruStore = lruStore' - , lruWeight = lruWeight - evictedWeight - } - where - (evicted, lruStore') = OrdPSQ.atMostView (t, maximumLRUTick) lruStore - evictedWeight = sumOf (folded . _3 . _2) evicted - -newtype LRUHandle k t w v = LRUHandle { _getLRUHandle :: IORef (LRU k t w v, LRUTick) } - deriving (Eq) - -initLRUHandle :: forall k t w v m. - ( MonadIO m - , Integral w - ) - => w -- ^ @lruMaximumWeight@ - -> m (LRUHandle k t w v) -initLRUHandle maxWeight = fmap LRUHandle . newIORef $ initLRU maxWeight - -insertLRUHandle :: forall k t w v m. - ( MonadIO m - , Ord k, Ord t - , Integral w - , NFData k, NFData t, NFData w, NFData v - ) - => LRUHandle k t w v - -> k - -> t - -> (v, w) - -> m () -insertLRUHandle (LRUHandle lruVar) k t newVal - = modifyIORef' lruVar $ force . uncurry (insertLRU k t $ Just newVal) - -lookupLRUHandle :: forall k t w v m. - ( MonadIO m - , Ord k - ) - => LRUHandle k t w v - -> k - -> m (Maybe (v, w)) -lookupLRUHandle (LRUHandle lruVar) k - = views _1 (lookupLRU k) <$> readIORef lruVar - -touchLRUHandle :: forall k t w v m. - ( MonadIO m - , Ord k, Ord t - , Integral w - , NFData k, NFData t, NFData w, NFData v - ) - => LRUHandle k t w v - -> k - -> t - -> m (Maybe (v, w)) -touchLRUHandle (LRUHandle lruVar) k t = do - oldLRU <- readIORef lruVar - let (newLRU, touched) = uncurry (touchLRU k t) oldLRU - force newLRU `seq` writeIORef lruVar newLRU - return touched - -timeoutLRUHandle :: forall k t w v m. - ( MonadIO m - , Ord k, Ord t - , Integral w - , NFData k, NFData t, NFData w, NFData v - ) - => LRUHandle k t w v - -> t - -> m () -timeoutLRUHandle (LRUHandle lruVar) t - = modifyIORef' lruVar $ force . over _1 (timeoutLRU t) - -readLRUHandle :: MonadIO m - => LRUHandle k t w v - -> m (LRU k t w v, LRUTick) -readLRUHandle (LRUHandle lruVar) = readIORef lruVar diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index 4eeefbb75..31f29e6c6 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -19,9 +19,6 @@ module Utils.Metrics , observeDeletedUnreferencedFiles, observeDeletedUnreferencedChunks, observeInjectedFiles, observeRechunkedFiles , registerJobWorkerQueueDepth , observeMissingFiles - , LRUMetrics, LRULabel(..) - , lruMetrics - , InjectInhibitMetrics, injectInhibitMetrics , PoolMetrics, PoolLabel(..) , poolMetrics , observeDatabaseConnectionOpened, observeDatabaseConnectionClosed @@ -53,11 +50,6 @@ import Jobs.Types import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap -import Data.IntervalMap.Strict (IntervalMap) -import qualified Data.IntervalMap.Strict as IntervalMap - -import qualified Data.Foldable as F - import qualified Utils.Pool as Custom import GHC.Stack @@ -272,57 +264,6 @@ relabel :: Text -> Text -> SampleGroup -> SampleGroup relabel l s (SampleGroup i t ss) = SampleGroup i t . flip map ss $ \(Sample k lbls v) -> Sample k ((l, s) : filter (views _1 $ (/=) l) lbls) v -data LRUMetrics = LRUMetrics - -data LRULabel = LRUFileSourcePrewarm - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) - deriving anyclass (Universe, Finite) - -nullaryPathPiece ''LRULabel $ camelToPathPiece' 1 - -lruMetrics :: Integral w - => LRULabel - -> LRUHandle k t w v - -> Metric LRUMetrics -lruMetrics lbl lh = Metric $ return (LRUMetrics, collectLRUMetrics) - where - labelLru = relabel "lru" - - collectLRUMetrics = map (labelLru $ toPathPiece lbl) <$> do - (lru, _) <- readLRUHandle lh - return - [ SampleGroup sizeInfo GaugeType - [ Sample "lru_size" [] . encodeUtf8 . tshow $ lruStoreSize lru - ] - , SampleGroup weightInfo GaugeType - [ Sample "lru_weight" [] . encodeUtf8 . tshow . toInteger $ getLRUWeight lru - ] - ] - sizeInfo = Info "lru_size" - "Number of entries in the LRU" - weightInfo = Info "lru_weight" - "Sum of weights of entries in the LRU" - -data InjectInhibitMetrics = InjectInhibitMetrics - -injectInhibitMetrics :: TVar (IntervalMap UTCTime (Set FileContentReference)) - -> Metric InjectInhibitMetrics -injectInhibitMetrics tvar = Metric $ return (InjectInhibitMetrics, collectInjectInhibitMetrics) - where - collectInjectInhibitMetrics = do - inhibits <- readTVarIO tvar - return - [ SampleGroup intervalsInfo GaugeType - [ Sample "uni2work_inject_inhibited_intervals_count" [] . encodeUtf8 . tshow $ IntervalMap.size inhibits - ] - , SampleGroup hashesInfo GaugeType - [ Sample "uni2work_inject_inhibited_hashes_count" [] . encodeUtf8 . tshow . Set.size $ F.fold inhibits - ] - ] - intervalsInfo = Info "uni2work_inject_inhibited_intervals_count" - "Number of distinct time intervals in which we don't transfer some files from upload cache to db" - hashesInfo = Info "uni2work_inject_inhibited_hashes_count" - "Number of files which we don't transfer from upload cache to db during some interval" data PoolMetrics = PoolMetrics From 3e6717904a2c6d9f58edfb6a3cc59454dad2663a Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 4 Oct 2024 16:13:01 +0200 Subject: [PATCH 032/187] chore(occurrences): workaround provide simple room field with least recent suggestions --- src/Handler/Utils/Form.hs | 32 +++++++++++++++++++++++++-- src/Handler/Utils/Form/Occurrences.hs | 6 ++--- src/Utils/Form.hs | 1 + 3 files changed, 34 insertions(+), 5 deletions(-) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 24ceb7b92..e7713934c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-24 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -44,6 +44,7 @@ import qualified Data.Conduit.List as C (mapMaybe, mapMaybeM) import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect) +import Database.Persist.Sql.Raw.QQ import qualified Data.Set as Set import qualified Data.Sequence as Seq @@ -288,7 +289,7 @@ multiActionOpts :: forall action a. -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) -multiActionOpts = multiActionOpts' mpopt +multiActionOpts = multiActionOpts' mpreq multiAction' :: forall action a. ( RenderMessage UniWorX action, PathPiece action, Ord action ) @@ -2342,6 +2343,33 @@ examModeForm mPrev = examMode examRequiredEquipmentFromEither (Left c) = ExamRequiredEquipmentCustom c +roomReferenceSimpleField :: Field Handler RoomReference +roomReferenceSimpleField = + convertField RoomReferenceSimple getRoom (textField & cfStrip & addDatalist roomReferenceSimpleSuggestions) + where + getRoom RoomReferenceSimple{..} = roomRefText + getRoom RoomReferenceLink{} = mempty + +roomReferenceSimpleSuggestions :: HandlerFor UniWorX (OptionList Text) +roomReferenceSimpleSuggestions = do + suggsRaw <- runDB [sqlQQ| + SELECT room FROM ( + SELECT DISTINCT ON (room) + j.value #> '{room,text}' AS room + , t.@{TutorialLastChanged} AS changed + FROM ^{Tutorial} AS t + , jsonb_array_elements((@{TutorialTime}->'exceptions') || (@{TutorialTime}->'scheduled')) AS j + ORDER BY 1, 2 DESC + ) AS sq + WHERE room IS NOT NULL + ORDER BY changed DESC + LIMIT 7; + |] + return $ mkOptionList $ fmap (\(E.unSingle -> t) -> Option t t t) suggsRaw + -- suggs <- liftHandler $ runDBRead $ E.select $ do + -- tut <- E.from $ E.table @Tutorial + -- return $ tut E.^. tutorialTime E.#>>. ["scheduled","1","room","text"] + roomReferenceFormOpt :: FieldSettings UniWorX -> Maybe (Maybe RoomReference) -> AForm Handler (Maybe RoomReference) diff --git a/src/Handler/Utils/Form/Occurrences.hs b/src/Handler/Utils/Form/Occurrences.hs index 767b9f5c7..9a70af25b 100644 --- a/src/Handler/Utils/Form/Occurrences.hs +++ b/src/Handler/Utils/Form/Occurrences.hs @@ -63,7 +63,7 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing -- DEBUG TODO -- <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) Nothing - <*> pure Nothing + <*> aopt roomReferenceSimpleField (fslI MsgTableTutorialRoom) Nothing ) ] ) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing @@ -101,8 +101,8 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing -- DEBUG TODO - <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) Nothing - -- <*> pure Nothing + -- <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) (Just Nothing) -- still does not work + <*> aopt roomReferenceSimpleField (fslI MsgTableTutorialRoom) Nothing ) , ( ExceptionKindNoOccur , ExceptNoOccur diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 6a48bdec4..1f88144d6 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -903,6 +903,7 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m isoField :: Functor m => AnIso' a b -> Field m a -> Field m b isoField (cloneIso -> fieldIso) = convertField (view fieldIso) (review fieldIso) +-- | Also see non-monadic `Yesod.Form.Functions.convertField` convertFieldM :: forall m a b. Monad m => (a -> m b) -> (b -> a) -> Field m a -> Field m b convertFieldM = checkMMap . ((fmap Right .) :: (a -> m b) -> (a -> m (Either (SomeMessage (HandlerSite m)) b))) From 0a5b0fcefffe9f6f27abc26a53f827dbd6d44375 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 4 Oct 2024 16:13:40 +0200 Subject: [PATCH 033/187] chore(build): limit max compile cpu cores to 5 --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 7e7a78efa..500d1555e 100644 --- a/package.yaml +++ b/package.yaml @@ -260,7 +260,7 @@ ghc-options: - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures - -fno-max-relevant-binds - - -j + - -j5 - -freduction-depth=0 - -fprof-auto-calls - -g From f6b87a09b0f600ef62e4adb797759160c0721672 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 4 Oct 2024 16:16:32 +0200 Subject: [PATCH 034/187] fix(build): occurrences no longer have a READ instance --- test/Model/TypesSpec.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index fe9eb7325..57ae987aa 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -66,8 +66,8 @@ instance Arbitrary Day where shrink day = let (y, m, d) = toGregorian day dayShrink = [fromGregorian y m (d - 1) | d > 1] - monthShrink = [fromGregorian y (m - 1) d | m > 1] - yearShrink = [fromGregorian (y - 1) m d | y > 2000] + monthShrink = [fromGregorian y (m - 1) d | m > 1] + yearShrink = [fromGregorian (y - 1) m d | y > 2000] in dayShrink ++ monthShrink ++ yearShrink instance CoArbitrary Day where @@ -75,7 +75,7 @@ instance CoArbitrary Day where -} instance Arbitrary TermIdentifier where - arbitrary = TermIdentifier <$> arbitrary + arbitrary = TermIdentifier <$> arbitrary shrink = fmap TermIdentifier . shrink . year instance CoArbitrary TermIdentifier instance Function TermIdentifier @@ -399,7 +399,7 @@ instance Arbitrary UploadNonce where instance Arbitrary SchoolAuthorshipStatementMode where arbitrary = genericArbitrary - + instance Arbitrary SheetAuthorshipStatementMode where arbitrary = genericArbitrary @@ -455,7 +455,7 @@ spec = do lawsCheckHspec (Proxy @TermIdentifier) [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ] lawsCheckHspec (Proxy @Occurrences) - [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ] + [ eqLaws, ordLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @StudyFieldType) [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, persistFieldLaws ] lawsCheckHspec (Proxy @Theme) @@ -541,11 +541,11 @@ spec = do describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ - \term -> termFromText (termToText term) == Right term + \term -> termFromText (termToText term) == Right term it "has compatible encoding/decoding to/from Rational" . property $ \term -> termFromRational (termToRational term) == term -- This is not sufficient - --it "has compatible encoding/decoding to/from PersistValue" . property $ + --it "has compatible encoding/decoding to/from PersistValue" . property $ -- \term -> fromPersistValue (toPersistValue term) == term it "has human readable year encoding to Rational" . property $ \term -> truncate (termToRational term) == year term From 452cdf44421104896d6fac3feb4079465ec3358d Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 7 Oct 2024 12:58:22 +0200 Subject: [PATCH 035/187] fix(test): add arbitrart instances and adjust argument changes to tests --- test/Handler/Utils/SubmissionSpec.hs | 16 ++++++++-------- test/Model/TypesSpec.hs | 2 +- test/ModelSpec.hs | 5 +++-- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs index ed50724ba..402e9fc9b 100644 --- a/test/Handler/Utils/SubmissionSpec.hs +++ b/test/Handler/Utils/SubmissionSpec.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -49,7 +49,7 @@ makeUsers (fromIntegral -> n) = do users <- forM users' $ \u -> do i <- atomically $ readTVar userNumber <* modifyTVar userNumber succ let baseid = "user." <> tshow i - u' = u { userIdent = CI.mk baseid + u' = u { userIdent = CI.mk baseid , userEmail = CI.mk $ baseid <> "@example.com" , userLdapPrimaryKey = Just $ baseid <> ".ldap" } @@ -82,7 +82,7 @@ distributionExample mkParameters setupHook cont = do participants' <- liftIO $ take (fromIntegral subsN') <$> shuffleM participants let loads' = loads ++ replicate (fromIntegral $ correctorsN - genericLength loads) Nothing - + submissions <- forM participants' $ \(Entity uid _) -> do sub@(Entity subId _) <- insertEntity $ Submission sid @@ -102,7 +102,7 @@ distributionExample mkParameters setupHook cont = do mapM_ (\(n, (subs, corrs)) -> setupHook n subs corrs) . zip [1..] $ map snd situations - -- situations' <- + -- situations' <- forM situations $ \(sid, (submissions, sheetCorrectors)) -> (sid, ) <$> do submissions' <- mapM (fmap fromJust . getEntity . entityKey) submissions sheetCorrectors' <- mapM (fmap fromJust . getEntity . entityKey) sheetCorrectors @@ -126,7 +126,7 @@ distributionExample mkParameters setupHook cont = do let key = find (\ (Entity _ (SheetCorrector uid _ _ _)) -> Just uid == submissionRatingBy) $ concatMap (\(_, (_, corrs)) -> corrs) situations sheet = getFirst . foldMap (\(n, (sid, _)) -> First $ guardOn (sid == submissionSheet) n) $ zip [1..] situations return (entityVal <$> key, Set.singleton (subId, sheet)) - + spec :: Spec spec = withApp . describe "Submission distribution" $ do @@ -196,16 +196,16 @@ spec = withApp . describe "Submission distribution" $ do void . insert $ Tutor tutId sheetCorrectorUser E.insertSelect . E.from $ \submissionUser -> do E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId - return $ TutorialParticipant E.<# E.val tutId E.<&> (submissionUser E.^. SubmissionUserUser) + return $ TutorialParticipant E.<# E.val tutId E.<&> (submissionUser E.^. SubmissionUserUser) E.<&> E.nothing ) (\result -> do let countResult = Map.map Set.size result countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult countResult' `shouldNotSatisfy` Map.member Nothing countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> fromIntegral subsSet == 50 * prop) . Map.toList - + -- -- Does not currently work, because `User`s are reused within `distributionExample`, so submissions end up having more associated course-tutors, because the same user might be a member of a tutorial created for another submission - -- + -- -- let subs = fold tutSubIds' -- forM_ subs $ \subId -> do -- let tutors = Map.keysSet $ Map.filter (Set.member subId) tutSubIds' diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 57ae987aa..078a928ad 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -318,7 +318,7 @@ instance Arbitrary CsvOptions where arbitrary = CsvOptions <$> arbitrary <*> arbitrary - <*> suchThat arbitrary (maybe True $ not . elem (Char.chr 0)) + <*> suchThat arbitrary (maybe True $ notElem (Char.chr 0)) shrink = genericShrink instance Arbitrary CsvPreset where diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index 28a3ecc4d..5d9e3a969 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -41,6 +41,8 @@ import System.IO.Unsafe (unsafePerformIO) import Data.Universe +deriving newtype instance Arbitrary a => Arbitrary (JSONB a) + instance Arbitrary EmailAddress where arbitrary = do local <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com")) @@ -86,7 +88,6 @@ instance Arbitrary Tutorial where <*> (fmap getPositive <$> arbitrary) <*> arbitrary <*> arbitrary - <*> arbitrary <*> (fmap (CI.mk . pack . getPrintableString) <$> arbitrary) <*> arbitrary <*> arbitrary From a7b08b1ae5f3e5a1537e70da5de8ee08f431c0f9 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 7 Oct 2024 18:31:02 +0200 Subject: [PATCH 036/187] fix(occurrences): room occurrence form works now --- src/Database/Persist/Types/Instances.hs | 2 +- src/Handler/Utils/Form.hs | 18 ++++++++---------- src/Handler/Utils/Form/Occurrences.hs | 12 +++++------- src/Utils/DateTime.hs | 9 +++++---- 4 files changed, 19 insertions(+), 22 deletions(-) diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs index e32ed5951..1cdf4a70a 100644 --- a/src/Database/Persist/Types/Instances.hs +++ b/src/Database/Persist/Types/Instances.hs @@ -27,7 +27,7 @@ instance Hashable LiteralType instance Binary LiteralType instance NFData LiteralType - + deriving instance Generic PersistValue instance Hashable PersistValue diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index e7713934c..93b707a70 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -16,16 +16,12 @@ import Utils.Form import Utils.Files import Handler.Utils.Form.Types - import Handler.Utils.Pandoc - import Handler.Utils.DateTime - import Handler.Utils.I18n - import Handler.Utils.Files - import Handler.Utils.Exam +import Handler.Utils.Memcached import Utils.Term @@ -2352,10 +2348,11 @@ roomReferenceSimpleField = roomReferenceSimpleSuggestions :: HandlerFor UniWorX (OptionList Text) roomReferenceSimpleSuggestions = do - suggsRaw <- runDB [sqlQQ| + suggsRaw :: [Text] <- $(memcachedByHere) (Just $ Right $ 30 * diffSecond) ("rooms-recently-used"::Text) (E.unSingle <<$>> runDB + [sqlQQ| SELECT room FROM ( SELECT DISTINCT ON (room) - j.value #> '{room,text}' AS room + j.value #>> '{room,text}' AS room , t.@{TutorialLastChanged} AS changed FROM ^{Tutorial} AS t , jsonb_array_elements((@{TutorialTime}->'exceptions') || (@{TutorialTime}->'scheduled')) AS j @@ -2364,8 +2361,9 @@ roomReferenceSimpleSuggestions = do WHERE room IS NOT NULL ORDER BY changed DESC LIMIT 7; - |] - return $ mkOptionList $ fmap (\(E.unSingle -> t) -> Option t t t) suggsRaw + |] ) + $logDebugS "Room" $ mconcat suggsRaw + return $ mkOptionList $ fmap (\t -> Option t t t) suggsRaw -- suggs <- liftHandler $ runDBRead $ E.select $ do -- tut <- E.from $ E.table @Tutorial -- return $ tut E.^. tutorialTime E.#>>. ["scheduled","1","room","text"] @@ -2406,7 +2404,7 @@ roomReferenceForm' noneOpt fs mPrev = multiActionAOpts opts opts' fs $ fmap clas Nothing -> pure Nothing Just RoomReferenceSimple' -> wFormToAForm $ do MsgRenderer mr <- getMsgRenderer - fmap (Just . RoomReferenceSimple) <$> wpreq (textField & cfStrip) (fslI MsgRoomReferenceSimpleText & addPlaceholder (mr MsgRoomReferenceSimpleTextPlaceholder) & maybe id (\n -> addName $ n <> "__text") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefText) + fmap (Just . RoomReferenceSimple) <$> wpreq (textField & cfStrip & addDatalist roomReferenceSimpleSuggestions) (fslI MsgRoomReferenceSimpleText & addPlaceholder (mr MsgRoomReferenceSimpleTextPlaceholder) & maybe id (\n -> addName $ n <> "__text") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefText) Just RoomReferenceLink' -> wFormToAForm $ do MsgRenderer mr <- getMsgRenderer roomRefLink' <- wpreq urlField (fslI MsgRoomReferenceLinkLink & addPlaceholder (mr MsgRoomReferenceLinkLinkPlaceholder) & maybe id (\n -> addName $ n <> "__link") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefLink) diff --git a/src/Handler/Utils/Form/Occurrences.hs b/src/Handler/Utils/Form/Occurrences.hs index 9a70af25b..5bc3f5dff 100644 --- a/src/Handler/Utils/Form/Occurrences.hs +++ b/src/Handler/Utils/Form/Occurrences.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -61,9 +61,8 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do <$> apreq (selectField' Nothing optionsFinite) (fslI MsgOccurrenceWeekDay & addName (nudge "occur-week-day")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing - -- DEBUG TODO - -- <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) Nothing - <*> aopt roomReferenceSimpleField (fslI MsgTableTutorialRoom) Nothing + <*> roomReferenceForm' Nothing (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) Nothing + -- <*> aopt roomReferenceSimpleField (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) (Just Nothing) ) ] ) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing @@ -100,9 +99,8 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do <$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing - -- DEBUG TODO - -- <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom) (Just Nothing) -- still does not work - <*> aopt roomReferenceSimpleField (fslI MsgTableTutorialRoom) Nothing + <*> roomReferenceForm' Nothing (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) Nothing + -- <*> aopt roomReferenceSimpleField (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) Nothing ) , ( ExceptionKindNoOccur , ExceptNoOccur diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 27ba25ecb..5ad9e2de6 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -16,8 +16,8 @@ module Utils.DateTime , mkDateTimeFormatter , nominalHour, nominalMinute , minNominalYear, avgNominalYear - , diffMinute, diffHour, diffDay - , module Zones + , diffSecond, diffMinute, diffHour, diffDay + , module Zones , day , utctDayMidnight ) where @@ -86,7 +86,7 @@ timeLocaleMap extra@((_, defLocale):_) = do letE [localeMap'] (varE localeMap) compileTime :: ExpQ -- Type UTCTime -compileTime = do +compileTime = do now <- runIO getCurrentTime [e|now|] @@ -166,7 +166,8 @@ avgNominalYear = fromRational $ 365.2425 * toRational nominalDay -- DiffTime -- -------------- -diffMinute, diffHour, diffDay :: DiffTime +diffSecond, diffMinute, diffHour, diffDay :: DiffTime +diffSecond = 1 diffMinute = 60 diffHour = 3600 diffDay = 86400 From 46f777740f13c7d51d6ed1240860528ff7833588 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 8 Oct 2024 10:08:04 +0200 Subject: [PATCH 037/187] fix(memcached): using memcachedHere did not compile due to staging problems --- src/Handler/Utils/Memcached.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 2877bd9af..1c4a49bed 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -377,10 +377,17 @@ newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a instance NFData a => NFData (MemcachedUnkeyedLoc a) where rnf MemcachedUnkeyedLoc{..} = rnf unMemcachedUnkeyedLoc +-- avoids staging restictions +withMemcachedUnkeyedLoc :: Functor f => (f (MemcachedUnkeyedLoc a) -> f (MemcachedUnkeyedLoc a)) -> (f a -> f a) +withMemcachedUnkeyedLoc act = fmap unMemcachedUnkeyedLoc . act . fmap MemcachedUnkeyedLoc +{-# INLINE withMemcachedUnkeyedLoc #-} + +-- Evaluates to: $(memcachedHere) :: forall a m. ( MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, Typeable a, Binary a) +-- => Maybe Expiry -> m a -> m a memcachedHere :: Q Exp memcachedHere = do loc <- location - [e| \mExp -> fmap unMemcachedUnkeyedLoc . memcachedBy mExp loc . fmap MemcachedUnkeyedLoc |] + [e| \mExp -> withMemcachedUnkeyedLoc (memcachedBy mExp loc) |] newtype MemcachedKeyedLoc a = MemcachedKeyedLoc { unMemcachedKeyedLoc :: a } deriving newtype (Eq, Ord, Show, Binary) @@ -395,6 +402,8 @@ withMemcachedKeyedLoc' :: (Functor f, Functor f') => (f (MemcachedKeyedLoc a) -> withMemcachedKeyedLoc' act = fmap (fmap unMemcachedKeyedLoc) . act . fmap MemcachedKeyedLoc {-# INLINE withMemcachedKeyedLoc' #-} +-- Evaluates to: $(memcachedByHere) :: forall a m k. ( MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, Typeable a, Binary a, Binary k) +-- => Maybe Expiry -> k -> m a -> m a memcachedByHere :: Q Exp memcachedByHere = do loc <- location From 4bca7580d0ae5ec57ac9afe727436e6f09a7a61c Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 8 Oct 2024 13:01:44 +0200 Subject: [PATCH 038/187] refactor(occurrences): fold RoomReference into Occurrences, completed --- .../utils/table_column/de-de-formal.msg | 4 +-- messages/uniworx/utils/table_column/en-eu.msg | 4 +-- src/Handler/Course/Show.hs | 2 +- src/Handler/Course/User.hs | 2 +- src/Handler/Tutorial/List.hs | 2 +- src/Handler/Utils/Form.hs | 33 ++++++++++--------- src/Handler/Utils/Form/Occurrences.hs | 12 +++---- src/Utils.hs | 11 +++++++ templates/tutorial-participants.hamlet | 2 +- .../occurrence/cell/except-occur.hamlet | 2 +- 10 files changed, 43 insertions(+), 31 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index a4d2818fa..f3cc58366 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -48,11 +48,11 @@ TableNotPassed: Nicht bestanden TableTutorialTutors: Ausbilder TableTutorialName: Bezeichnung TableTutorialType: Art -TableTutorialRoom: Regulärer Raum +TableTutorialRoom: Raum TableTutorialRoomHidden: Raum nur für Teilnehmer TableTutorialRoomIsUnset !ident-ok: — TableTutorialRoomIsHidden: Raum wird nur Teilnehmern angezeigt -TableTutorialTime: Zeit +TableTutorialOccurrence: Termin TableTutorialDeregisterUntil: Abmeldungen bis TableTutorialFirstDay: Starttag TableActionsHead: Aktionen diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index d213ba05f..65eb98114 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -48,14 +48,14 @@ TableNotPassed: Failed TableTutorialTutors: Instructors TableTutorialName: Name TableTutorialType: Type -TableTutorialRoom: Regular room +TableTutorialRoom: Room TableTutorialRoomHidden: Room only for participants TableTutorialRoomIsUnset: — TableTutorialRoomIsHidden: Room is only displayed to participants TableTutorialDeregisterUntil: Deregister until TableTutorialFirstDay: Start date TableActionsHead: Actions -TableTutorialTime: Time +TableTutorialOccurrence: Session TableNoFilter: No restriction TableUserMatriculation: AVS number TableColumnStudyFeatures: Features of study diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index d211bcda5..8b5de3739 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -180,7 +180,7 @@ getCShowR tid ssh csh = do
    • ^{nameEmailWidget' tutor} |] - , sortable Nothing (i18nCell MsgTableTutorialTime) $ \res -> + , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \res -> let roomHidden = res ^. resultHideRoom ttime = res ^. resultTutorial . _entityVal . _tutorialTime in occurrencesCell roomHidden ttime diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 2d2d221c2..25b8bf904 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -444,7 +444,7 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
    • ^{userEmailWidget usr} |] - , sortable Nothing (i18nCell MsgTableTutorialTime) $ occurrencesCell False . view (_dbrOutput . _1 . _entityVal . _tutorialTime) + , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ occurrencesCell False . view (_dbrOutput . _1 . _entityVal . _tutorialTime) ] dbtSorting = mconcat [ singletonMap "type" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialType diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index a628215c2..9f50c1182 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -61,7 +61,7 @@ getCTutorialListR tid ssh csh = do |] , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \(view $ $(multifocusL 2) (resultTutorial . _entityVal) resultParticipants -> (Tutorial{..}, n)) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . tshow) tutorialCapacity - , sortable Nothing (i18nCell MsgTableTutorialTime) $ \res -> + , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \res -> let roomHidden = res ^. resultHideRoom ttime = res ^. resultTutorial . _entityVal . _tutorialTime in occurrencesCell roomHidden ttime diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 93b707a70..65fef8d50 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -285,7 +285,7 @@ multiActionOpts :: forall action a. -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) -multiActionOpts = multiActionOpts' mpreq +multiActionOpts = multiActionOpts' mpopt multiAction' :: forall action a. ( RenderMessage UniWorX action, PathPiece action, Ord action ) @@ -2348,21 +2348,22 @@ roomReferenceSimpleField = roomReferenceSimpleSuggestions :: HandlerFor UniWorX (OptionList Text) roomReferenceSimpleSuggestions = do - suggsRaw :: [Text] <- $(memcachedByHere) (Just $ Right $ 30 * diffSecond) ("rooms-recently-used"::Text) (E.unSingle <<$>> runDB - [sqlQQ| - SELECT room FROM ( - SELECT DISTINCT ON (room) - j.value #>> '{room,text}' AS room - , t.@{TutorialLastChanged} AS changed - FROM ^{Tutorial} AS t - , jsonb_array_elements((@{TutorialTime}->'exceptions') || (@{TutorialTime}->'scheduled')) AS j - ORDER BY 1, 2 DESC - ) AS sq - WHERE room IS NOT NULL - ORDER BY changed DESC - LIMIT 7; - |] ) - $logDebugS "Room" $ mconcat suggsRaw + -- suggsRaw :: [Text] <- $(memcachedByHere) (Just $ Right $ 30 * diffSecond) ("rooms-recently-used"::Text) (E.unSingle <<$>> runDB + suggsRaw :: [Text] <- $(memcachedHere) (Just $ Right $ 42 * diffSecond) $ catchAllMonoid $ E.unSingle <<$>> runDB + [sqlQQ| + SELECT room FROM ( + SELECT DISTINCT ON (room) + j.value #>> '{room,text}' AS room + , t.@{TutorialLastChanged} AS changed + FROM ^{Tutorial} AS t + , jsonb_array_elements((@{TutorialTime}->'exceptions') || (@{TutorialTime}->'scheduled')) AS j + ORDER BY 1, 2 DESC + ) AS sq + WHERE room IS NOT NULL + ORDER BY changed DESC + LIMIT 7; + |] + -- $logDebugS "Room" $ mconcat suggsRaw return $ mkOptionList $ fmap (\t -> Option t t t) suggsRaw -- suggs <- liftHandler $ runDBRead $ E.select $ do -- tut <- E.from $ E.table @Tutorial diff --git a/src/Handler/Utils/Form/Occurrences.hs b/src/Handler/Utils/Form/Occurrences.hs index 5bc3f5dff..c37368891 100644 --- a/src/Handler/Utils/Form/Occurrences.hs +++ b/src/Handler/Utils/Form/Occurrences.hs @@ -59,9 +59,9 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do (Map.fromList [ ( ScheduleKindWeekly , ScheduleWeekly <$> apreq (selectField' Nothing optionsFinite) (fslI MsgOccurrenceWeekDay & addName (nudge "occur-week-day")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing - <*> roomReferenceForm' Nothing (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end" )) Nothing + <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom & addName (nudge "occur-room" )) (Just Nothing) -- <*> aopt roomReferenceSimpleField (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) (Just Nothing) ) ] @@ -97,9 +97,9 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do (Map.fromList [ ( ExceptionKindOccur , ExceptOccur <$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing - <*> roomReferenceForm' Nothing (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end" )) Nothing + <*> roomReferenceFormOpt (fslI MsgTableTutorialRoom & addName (nudge "occur-room" )) (Just Nothing) -- <*> aopt roomReferenceSimpleField (fslI MsgTableTutorialRoom & addName (nudge "occur-room")) Nothing ) , ( ExceptionKindNoOccur diff --git a/src/Utils.hs b/src/Utils.hs index 821da0d7b..d8545175e 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1190,6 +1190,17 @@ maybeCatchAll act = catch act ignore ignore :: Monad m => SomeException -> m (Maybe a) ignore _ = return Nothing +-- | Ignore all errors by returning a monadic default value. +catchAllDefault :: MonadCatch m => m a -> m (Maybe a) -> m a +catchAllDefault dft = fromMaybeM dft . maybeCatchAll + +-- | Ignore all errors by returning mempty. (Not sure if this function is a good idea) +catchAllMonoid :: (MonadCatch m, Monoid a) => m a -> m a +catchAllMonoid act = catch act ignore + where + ignore :: (Monad m, Monoid a) => SomeException -> m a + ignore _ = pure mempty + maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b maybeExceptT err act = lift act >>= maybe (throwE err) return diff --git a/templates/tutorial-participants.hamlet b/templates/tutorial-participants.hamlet index ef2d80c93..8886de37a 100644 --- a/templates/tutorial-participants.hamlet +++ b/templates/tutorial-participants.hamlet @@ -6,7 +6,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
      -
      _{MsgTableTutorialTime} +
      _{MsgTableTutorialOccurrence}
      ^{occurrencesWidget tutorialRoomHidden tutorialTime}
      _{MsgTableTutorialTutors} diff --git a/templates/widgets/occurrence/cell/except-occur.hamlet b/templates/widgets/occurrence/cell/except-occur.hamlet index f75f8f00c..f17dbce9d 100644 --- a/templates/widgets/occurrence/cell/except-occur.hamlet +++ b/templates/widgets/occurrence/cell/except-occur.hamlet @@ -5,7 +5,7 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later $if not (null occurrencesScheduled') - _{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'} + _{MsgExceptionKindOccur} #{exceptStart'}–#{exceptEnd'} $if not roomHidden ^{foldMap roomReferenceWidget exceptRoom} $else From b78c898ebf85fe91ecfb7ab52cee84182422df6c Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 8 Oct 2024 17:47:46 +0200 Subject: [PATCH 039/187] fix(avs): fix #224 repeated superior changes no longer occur furthermore AdminProblems are only inserted if the same problem does not exist unsolved --- src/Handler/Utils/Avs.hs | 95 ++++++++++++++++++++-------------------- 1 file changed, 48 insertions(+), 47 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index b331357e7..05af26715 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -402,53 +402,54 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv superReasonComDef = tshow SupervisorReasonCompanyDefault newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done - case oldAvsFirmInfo of - _ | Just newCompanyId == oldCompanyId -- company unchanged entirely - -> return mempty -- => do nothing - (Just oafi) | isJust (view _avsFirmPostAddressSimple oafi) - && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR - || isJust (view _avsFirmPrimaryEmail oafi) - && ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged - -> do -- => just update user company association, keeping supervision privileges - case oldCompanyId of - Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists - Just ocid -> do - void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings - void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions - , UserSupervisorCompany ==. Just ocid -- to new company, regardless of - , UserSupervisorReason ==. Just superReasonComDef] -- user - [ UserSupervisorCompany =. Just newCompanyId] - return mempty - _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company - -> do - whenIsJust oldCompanyId $ \oldCid -> do - deleteBy $ UniqueUserCompany usrId oldCid - deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) - return mempty - _ -- company changed completely - -> do - (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId - mapM_ reportAdminProblem problems - -- Following line does not type, hence additional parameter needed - -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates) - return pst_up - -- SPECIALISED CODE, PROBABLY DEPRECATED - -- switch user company, keeping old priority - -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case - -- Nothing -> - -- void $ insertUnique newUserComp - -- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do - -- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute - -- delete ucidOld - -- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds - -- -- adjust supervison - -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] - -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr - -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr - -- addDefaultSupervisors' newCompanyId $ singleton usrId - -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) - -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId - -- return pst_up + usr_up2 <- case oldAvsFirmInfo of + _ | Just newCompanyId == oldCompanyId -- company unchanged entirely + -> return mempty -- => do nothing + (Just oafi) | isJust (view _avsFirmPostAddressSimple oafi) + && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR + || isJust (view _avsFirmPrimaryEmail oafi) + && ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged + -> do -- => just update user company association, keeping supervision privileges + case oldCompanyId of + Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists + Just ocid -> do + void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings + void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions + , UserSupervisorCompany ==. Just ocid -- to new company, regardless of + , UserSupervisorReason ==. Just superReasonComDef] -- user + [ UserSupervisorCompany =. Just newCompanyId] + return mempty + _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company + -> do + whenIsJust oldCompanyId $ \oldCid -> do + deleteBy $ UniqueUserCompany usrId oldCid + deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) + return mempty + _ -- company changed completely + -> do + (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId + mapM_ reportAdminProblem problems + -- Following line does not type, hence additional parameter needed + -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates) + return pst_up + -- SPECIALISED CODE, PROBABLY DEPRECATED + -- switch user company, keeping old priority + -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case + -- Nothing -> + -- void $ insertUnique newUserComp + -- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do + -- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute + -- delete ucidOld + -- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds + -- -- adjust supervison + -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] + -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr + -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr + -- addDefaultSupervisors' newCompanyId $ singleton usrId + -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) + -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId + -- return pst_up + upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId -- ensure firmInfo superior is supervisor for this user update usrId usr_up2 -- update user by company switch first (due to possible conflicts with usr_up2) update usrId usr_up1 -- update user eventually update uaId avs_ups -- update stored avsinfo for future updates From 0c7899626019a9498cf02fe4a47b08c2364bd07b Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 9 Oct 2024 12:21:31 +0200 Subject: [PATCH 040/187] fix(avs): fix #225 by skipping firm updates entirely if AVS FirmInfo is unchanged for previously seen values for AVS User to be updated --- src/Handler/Utils/Avs.hs | 95 ++++++++++++++++++++-------------------- 1 file changed, 47 insertions(+), 48 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 05af26715..b331357e7 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -402,54 +402,53 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv superReasonComDef = tshow SupervisorReasonCompanyDefault newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done - usr_up2 <- case oldAvsFirmInfo of - _ | Just newCompanyId == oldCompanyId -- company unchanged entirely - -> return mempty -- => do nothing - (Just oafi) | isJust (view _avsFirmPostAddressSimple oafi) - && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR - || isJust (view _avsFirmPrimaryEmail oafi) - && ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged - -> do -- => just update user company association, keeping supervision privileges - case oldCompanyId of - Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists - Just ocid -> do - void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings - void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions - , UserSupervisorCompany ==. Just ocid -- to new company, regardless of - , UserSupervisorReason ==. Just superReasonComDef] -- user - [ UserSupervisorCompany =. Just newCompanyId] - return mempty - _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company - -> do - whenIsJust oldCompanyId $ \oldCid -> do - deleteBy $ UniqueUserCompany usrId oldCid - deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) - return mempty - _ -- company changed completely - -> do - (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId - mapM_ reportAdminProblem problems - -- Following line does not type, hence additional parameter needed - -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates) - return pst_up - -- SPECIALISED CODE, PROBABLY DEPRECATED - -- switch user company, keeping old priority - -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case - -- Nothing -> - -- void $ insertUnique newUserComp - -- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do - -- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute - -- delete ucidOld - -- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds - -- -- adjust supervison - -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] - -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr - -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr - -- addDefaultSupervisors' newCompanyId $ singleton usrId - -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) - -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId - -- return pst_up - upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId -- ensure firmInfo superior is supervisor for this user + case oldAvsFirmInfo of + _ | Just newCompanyId == oldCompanyId -- company unchanged entirely + -> return mempty -- => do nothing + (Just oafi) | isJust (view _avsFirmPostAddressSimple oafi) + && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR + || isJust (view _avsFirmPrimaryEmail oafi) + && ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged + -> do -- => just update user company association, keeping supervision privileges + case oldCompanyId of + Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists + Just ocid -> do + void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings + void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions + , UserSupervisorCompany ==. Just ocid -- to new company, regardless of + , UserSupervisorReason ==. Just superReasonComDef] -- user + [ UserSupervisorCompany =. Just newCompanyId] + return mempty + _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company + -> do + whenIsJust oldCompanyId $ \oldCid -> do + deleteBy $ UniqueUserCompany usrId oldCid + deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) + return mempty + _ -- company changed completely + -> do + (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId + mapM_ reportAdminProblem problems + -- Following line does not type, hence additional parameter needed + -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates) + return pst_up + -- SPECIALISED CODE, PROBABLY DEPRECATED + -- switch user company, keeping old priority + -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case + -- Nothing -> + -- void $ insertUnique newUserComp + -- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do + -- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute + -- delete ucidOld + -- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds + -- -- adjust supervison + -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] + -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr + -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr + -- addDefaultSupervisors' newCompanyId $ singleton usrId + -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) + -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId + -- return pst_up update usrId usr_up2 -- update user by company switch first (due to possible conflicts with usr_up2) update usrId usr_up1 -- update user eventually update uaId avs_ups -- update stored avsinfo for future updates From ce125b64956a5d9945123f525240533fff371bd2 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 9 Oct 2024 18:11:22 +0200 Subject: [PATCH 041/187] chore(daily): show course associated qualifications --- models/lms.model | 2 +- src/Handler/School/DayTasks.hs | 26 ++++++++++++++++++++++---- src/Handler/Utils/Qualification.hs | 12 ++++++++++++ src/Handler/Utils/Table/Cells.hs | 6 +++--- src/Handler/Utils/Table/Pagination.hs | 17 +++++++++++++++++ src/Model/Types/Avs.hs | 2 +- templates/table/cell/listInline.hamlet | 10 ++++++++++ test/Database/Fill.hs | 2 ++ 8 files changed, 68 insertions(+), 9 deletions(-) create mode 100644 templates/table/cell/listInline.hamlet diff --git a/models/lms.model b/models/lms.model index 9a7712c29..50b686fcf 100644 --- a/models/lms.model +++ b/models/lms.model @@ -24,7 +24,7 @@ Qualification -- across all schools, only one qualification may be a driving licence -- NO LONGER TRUE -- UniqueQualificationAvsLicence avsLicence !force -- either empty or unique -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints! - deriving Show Eq Generic + deriving Show Eq Generic Binary -- TODOs: -- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen? diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 5e6d8ba4e..e37793048 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -24,8 +24,9 @@ import qualified Data.Aeson as Aeson -- import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) -import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.Legacy as EL (on, from) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Database.Esqueleto.PostgreSQL.JSON as E @@ -100,8 +101,15 @@ type DailyTableExpr = `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) `E.InnerJoin` E.SqlExpr (Entity User) ) -type DailyTableOutput = E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity TutorialParticipant), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId))) -type DailyTableData = DBRow (Entity Course, Entity Tutorial, Entity TutorialParticipant, Entity User, E.Value (Maybe CompanyId)) +type DailyTableOutput = E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity TutorialParticipant), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId)), E.SqlExpr (E.Value (Maybe [QualificationId]))) +type DailyTableData = DBRow + ( Entity Course + , Entity Tutorial + , Entity TutorialParticipant + , Entity User + , E.Value (Maybe CompanyId) + , E.Value (Maybe [QualificationId]) + ) queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) queryCourse = $(sqlIJproj 4 1) @@ -133,6 +141,10 @@ resultUser = _dbrOutput . _4 resultCompanyId :: Traversal' DailyTableData CompanyId resultCompanyId = _dbrOutput . _5 . _unValue . _Just +resultCourseQualis :: Traversal' DailyTableData [QualificationId] +resultCourseQualis = _dbrOutput . _6 . _unValue . _Just + + instance HasEntity DailyTableData User where hasEntity = resultUser @@ -149,7 +161,12 @@ mkDailyTable isAdmin ssh nd = do EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser E.where_ $ tut E.^. TutorialId `E.in_` E.valList tuts - return (crs, tut, tpu, usr, selectCompanyUserPrime usr) + let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do + E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId + let cqQual = cq E.^. CourseQualificationQualification + cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual] + return $ E.arrayAggWith E.AggModeAll cqQual cqOrder + return (crs, tut, tpu, usr, selectCompanyUserPrime usr, associatedQualifications) dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtProj = dbtProjId dbtColonnade = mconcat @@ -160,6 +177,7 @@ mkDailyTable isAdmin ssh nd = do = row ^. resultCourse . _entityVal tutName = row ^. resultTutorial . _entityVal . _tutorialName in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName + , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid , colUserNameModalHdr MsgCourseParticipant ForProfileDataR diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index cec61ac9e..9bd59310d 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -18,6 +18,18 @@ import qualified Database.Esqueleto.Experimental as E -- might need TypeApplic import qualified Database.Esqueleto.Utils as E import Handler.Utils.Widgets (statusHtml) +import Handler.Utils.Memcached + + +-- A type for saving QualificationId -> Qualfication queries +newtype MemcachedQualification = MemcachedQualification { unMemachedQualification :: QualificationId } + deriving newtype (Eq, Ord, Show, Binary) +instance NFData MemcachedQualification where + rnf MemcachedQualification{..} = rnf unMemachedQualification + +retrieveQualification :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification) +retrieveQualification qid = liftHandler $ memcachedBy (Just . Right $ 7 * diffHour) (MemcachedQualification qid) $ runDBRead $ get qid + -- | Compute new valid date from old one and from validDuration in months -- Mainly to document which add months functions to use diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index c5bddd475..0d43a13fe 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -14,7 +14,7 @@ import Handler.Utils.DateTime import Handler.Utils.Widgets import Handler.Utils.Occurrences import Handler.Utils.LMS (lmsUserStatusWidget) -import Handler.Utils.Qualification (isValidQualification) +import Handler.Utils.Qualification (isValidQualification, retrieveQualification) type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles ! @@ -384,7 +384,7 @@ companyIdCell cid = companyCell csh csh False qualificationIdCell :: (IsDBTable m c) => QualificationId -> DBCell m c qualificationIdCell qid = anchorCellM' qual link name where - qual = liftHandler $ runDBRead $ get qid + qual = retrieveQualification qid link (Just Qualification{..}) = QualificationR qualificationSchool qualificationShorthand link Nothing = HelpR name Nothing = text2widget "Error: unknown QID" @@ -393,7 +393,7 @@ qualificationIdCell qid = anchorCellM' qual link name qualificationIdShortCell :: (IsDBTable m c) => QualificationId -> DBCell m c qualificationIdShortCell qid = anchorCellM' qual link name where - qual = liftHandler $ runDBRead $ get qid + qual = retrieveQualification qid link (Just Qualification{..}) = QualificationR qualificationSchool qualificationShorthand link Nothing = HelpR name Nothing = text2widget "Error: unknown QID" diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 10fb0d544..d1c449fde 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -61,6 +61,7 @@ module Handler.Utils.Table.Pagination , cellTooltip, cellTooltips, cellTooltipIcon, cellTooltipWgt , listCell, listCell', listCellOf, listCellOf' , ilistCell, ilistCell', ilistCellOf, ilistCellOf' + , listInlineCell, listInlineCell', ilistInlineCell, ilistInlineCell' , formCell, DBFormResult(..), getDBFormResult , dbSelect, dbSelectIf , (&) @@ -1853,6 +1854,22 @@ maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ toWidget $ x2widgetUnauth Nothing +listInlineCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a +listInlineCell = listInlineCell' . return + +listInlineCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a +listInlineCell' mkXS mkCell = ilistInlineCell' (otoList <$> mkXS) $ const mkCell + +ilistInlineCell :: (IsDBTable m a, MonoFoldableWithKey mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a +ilistInlineCell = ilistInlineCell' . return + +ilistInlineCell' :: (IsDBTable m a, MonoFoldableWithKey mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a +ilistInlineCell' mkXS mkCell = review dbCell . ([], ) $ do + xs <- mkXS + cells <- forM (otoKeyedList xs) $ + \(view dbCell . uncurry mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget + return $(widgetFile "table/cell/listInline") + listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a listCell = listCell' . return diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 26c0aad49..f0a9540bd 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -280,7 +280,7 @@ discernAvsIds someid = aux someid data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld - deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Finite, Universe, NFData) + deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Finite, Universe, NFData, Binary) instance ToJSON AvsLicence where -- toJSON al = Number $ fromEnum AvsLicence -- would do, but... diff --git a/templates/table/cell/listInline.hamlet b/templates/table/cell/listInline.hamlet new file mode 100644 index 000000000..2c4b83e33 --- /dev/null +++ b/templates/table/cell/listInline.hamlet @@ -0,0 +1,10 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
        + $forall (attrs, widget) <- cells +
      • + ^{widget} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8d584195d..d8646159f 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1037,6 +1037,8 @@ fillDb = do } insert_ $ CourseEdit jost now c when (tyear >= currentYear) $ insert_ $ CourseQualification c qid_f 2 + when (tyear == currentYear) $ insert_ $ CourseQualification c qid_r 4 + when (tyear == currentYear) $ insert_ $ CourseQualification c qid_rp 44 when (tyear >= succ currentYear) $ insert_ $ CourseQualification c qid_r 3 when (tyear >= succ (succ currentYear)) $ insert_ $ CourseQualification c qid_l 1 insert_ Sheet From 14140c982beb555c8ad00508195d2d2b6dda096a Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 11 Oct 2024 11:23:29 +0200 Subject: [PATCH 042/187] refactor(memcached): checking memcached key security mechanisms RESULTS: Keys for memcached use their Binary representation! This means that the following three are all interchangeable as a key: newtype Foo1 = Foo1 { someInt1 :: Int } deriving newtype (Binary) data Foo2 = Foo2 { someInt2 :: Int } deriving (Binary) type Foo3 = Int Therefore it is best to use $(memcachedHere) or $(memcachedByHere) if possible or add another type --- src/Handler/Utils/Memcached.hs | 9 +++++++++ src/Handler/Utils/Qualification.hs | 26 +++++++++++++++++++++++--- 2 files changed, 32 insertions(+), 3 deletions(-) diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 1c4a49bed..332d5948e 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -25,6 +25,15 @@ module Handler.Utils.Memcached , MemcachedException(..), AsyncTimeoutException(..) ) where +{- BEWARE: Keys for memcached use their Binary representation! + + This means that the following three are all interchangeable as a key: + newtype Foo1 = Foo1 { someInt1 :: Int } deriving newtype (Binary) + data Foo2 = Foo2 { someInt2 :: Int } deriving (Binary) + type Foo3 = Int + Therefore it is best to use $(memcachedHere) or $(memcachedByHere) if possible or add another type +-} + import Import.NoFoundation hiding (utc, exp) import Foundation.Type diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 9bd59310d..01489838a 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -21,14 +21,34 @@ import Handler.Utils.Widgets (statusHtml) import Handler.Utils.Memcached --- A type for saving QualificationId -> Qualfication queries -newtype MemcachedQualification = MemcachedQualification { unMemachedQualification :: QualificationId } +retrieveQualification :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification) +retrieveQualification qid = liftHandler $ $(memcachedByHere) (Just . Right $ 7 * diffHour) qid $ runDBRead $ get qid + +{- +This experiment proves that a newtype-wrapper is entirely ignored by the derived Binary instance, since +regardless whether the prime or unprimed version is used, the same QualificationId leads to a hit: + +newtype MemcachedQualification = MemcachedQualification { unMemachedQualification :: QualificationId } -- unnecessary, also see top comment in Handler.Utils.Memcached deriving newtype (Eq, Ord, Show, Binary) instance NFData MemcachedQualification where rnf MemcachedQualification{..} = rnf unMemachedQualification +-- note that data does not work as expected either, the binary instance is only distinguished by the addition of another element +data MemcachedQualification = MemcachedQualification { unMemachedQualification :: QualificationId } -- , someId :: Text } -- with Text works OK + deriving (Eq, Ord, Show, Generic, Binary) +instance NFData MemcachedQualification where + rnf MemcachedQualification{..} = rnf (unMemachedQualification, someId) + retrieveQualification :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification) -retrieveQualification qid = liftHandler $ memcachedBy (Just . Right $ 7 * diffHour) (MemcachedQualification qid) $ runDBRead $ get qid +retrieveQualification qid = liftHandler $ memcachedBy (Just . Right $ 7 * diffHour) (MemcachedQualification qid) $ do + $logWarnS "CACHE-MISS" [st|Retrieve Qualification #{tshow qid} with Newtype-wrapper.|] + runDBRead $ get qid + +retrieveQualification' :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification) +retrieveQualification' qid = liftHandler $ memcachedBy (Just . Right $ 7 * diffHour) qid $ do + $logWarnS "CACHE-MISS" [st|Retrieve Qualification #{tshow qid} directly without a wrapper.|] + runDBRead $ get qid +-} -- | Compute new valid date from old one and from validDuration in months From a113d43089c77320362828ba1ace9ddd19a9240c Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 14 Oct 2024 18:27:44 +0200 Subject: [PATCH 043/187] chore(TH): add sqlMIXproj to improve dbTable usage, also add card-nos to DayTask Table --- src/Database/Esqueleto/Utils/TH.hs | 28 ++++++++- src/Handler/LMS.hs | 13 +++-- src/Handler/School/DayTasks.hs | 68 ++++++++++++++++------ src/Utils/TH.hs | 92 ++++++++++++++++++++++++++++++ test/Database/Fill.hs | 4 +- 5 files changed, 179 insertions(+), 26 deletions(-) diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index 546d85b29..f996ae160 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -9,7 +9,7 @@ module Database.Esqueleto.Utils.TH , sqlInTuple, sqlInTuples , _unValue , unValueN, unValueNIs - , sqlIJproj, sqlLOJproj, sqlFOJproj + , sqlIJproj, sqlLOJproj, sqlFOJproj, sqlMIXproj, sqlMIXproj' ) where import ClassyPrelude @@ -99,7 +99,7 @@ unValueNIs arity uvIdx = do -- | Generic projections for InnerJoin-tuples -- gives I-th element of N-tuple of left-associative InnerJoin-pairs, i.e. -- --- > $(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n) +-- > $(sqlIJproj n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n) sqlIJproj :: Int -> Int -> ExpQ sqlIJproj = leftAssociativePairProjection 'E.InnerJoin @@ -108,3 +108,27 @@ sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin sqlFOJproj :: Int -> Int -> ExpQ sqlFOJproj = leftAssociativePairProjection 'E.FullOuterJoin + +-- | Generic projections for Join-tuple +-- gives i-th element of n-tuple of left-associative join pairs, i.e. +-- +-- > $(sqlMIXproj "IR" 3) :: ((t1 `E.InnerJoin` t2) `E.RightOuterJoin` t3) -> t3 +sqlMIXproj :: String -> Int -> ExpQ +sqlMIXproj = leftAssociativeProjection . map decodeJoin + where + decodeJoin 'I' = 'E.InnerJoin + decodeJoin 'L' = 'E.LeftOuterJoin + decodeJoin 'R' = 'E.RightOuterJoin + decodeJoin 'F' = 'E.FullOuterJoin + decodeJoin 'O' = 'E.FullOuterJoin + decodeJoin 'X' = 'E.CrossJoin + decodeJoin 'C' = 'E.CrossJoin + decodeJoin c = error $ "Database.Esqueleto.Utils.TH.sqlMIXproj: received unknown SQL join kind \"" ++ c:"\"" -- always raised at compile time, so this is ok + +-- Alternative using `refiy`, but impractical due to TH staging restrictions +-- and currently confuses type and expression constructors somehow +sqlMIXproj' :: Name -> Int -> ExpQ +sqlMIXproj' t i = do + ns <- extractConstructorNames t + -- ns' <- maybeMapM (lookupValueName . nameBase) ns -- failed attempt change type-constructor names to identical expression-constructors + leftAssociativeProjection ns i diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index cf8c25a68..3b27d165f 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -299,19 +299,22 @@ instance CsvColumnsExplained LmsTableCsv where type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity LmsUser) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) + ) +-- due to GHC staging restrictions, we use the preprocessor instead +#define LMS_TABLE_JOIN "IIL" queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) -queryQualUser = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1) +queryQualUser = $(sqlMIXproj LMS_TABLE_JOIN 1) queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1) +queryUser = $(sqlMIXproj LMS_TABLE_JOIN 2) queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser) -queryLmsUser = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1) +queryLmsUser = $(sqlMIXproj LMS_TABLE_JOIN 3) queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) -queryQualBlock = $(sqlLOJproj 2 2) +queryQualBlock = $(sqlMIXproj LMS_TABLE_JOIN 4) type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), E.Value (Maybe CompanyId), E.Value Bool) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index e37793048..f23b377bd 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -28,8 +28,10 @@ import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Legacy as EL (on, from) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.PostgreSQL.JSON ((@>.)) +import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.)) import Database.Esqueleto.Utils.TH -import Database.Esqueleto.PostgreSQL.JSON as E + data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing @@ -95,33 +97,59 @@ getDayTutorials ssh dlimit@(dstart, dend ) | otherwise = Nothing + type DailyTableExpr = - ( E.SqlExpr (Entity Course) - `E.InnerJoin` E.SqlExpr (Entity Tutorial) - `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) - `E.InnerJoin` E.SqlExpr (Entity User) + ( E.SqlExpr (Entity Course) + `E.InnerJoin` E.SqlExpr (Entity Tutorial) + `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) + `E.InnerJoin` E.SqlExpr (Entity User) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserAvs)) + ) +-- due to GHC staging restrictions, we use the preprocessor instead +#define DAILY_TABLE_JOIN "IIIL" + +-- force declarations before this point +$(return []) + + +type DailyTableOutput = E.SqlQuery + ( E.SqlExpr (Entity Course) + , E.SqlExpr (Entity Tutorial) + , E.SqlExpr (Entity TutorialParticipant) + , E.SqlExpr (Entity User) + , E.SqlExpr (Maybe (Entity UserAvs)) + , E.SqlExpr (E.Value (Maybe CompanyId)) + , E.SqlExpr (E.Value (Maybe [QualificationId])) ) -type DailyTableOutput = E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity TutorialParticipant), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId)), E.SqlExpr (E.Value (Maybe [QualificationId]))) type DailyTableData = DBRow ( Entity Course , Entity Tutorial , Entity TutorialParticipant , Entity User + , Maybe (Entity UserAvs) , E.Value (Maybe CompanyId) , E.Value (Maybe [QualificationId]) ) +-- force declarations before this point +$(return []) + + queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) -queryCourse = $(sqlIJproj 4 1) +queryCourse = $(sqlMIXproj DAILY_TABLE_JOIN 1) queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) -queryTutorial = $(sqlIJproj 4 2) +queryTutorial = $(sqlMIXproj DAILY_TABLE_JOIN 2) queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant) -queryParticipant = $(sqlIJproj 4 3) +-- queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) -- TODO reify seems problematic for now +queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3) queryUser :: DailyTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 4 4) +queryUser = $(sqlMIXproj DAILY_TABLE_JOIN 4) + +queryUserAvs :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserAvs)) +queryUserAvs = $(sqlMIXproj DAILY_TABLE_JOIN 5) resultCourse :: Lens' DailyTableData (Entity Course) resultCourse = _dbrOutput . _1 @@ -132,17 +160,17 @@ resultTutorial = _dbrOutput . _2 resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant) resultParticipant = _dbrOutput . _3 --- resultCompanyId :: Traversal' DailyTableData CompanyId --- resultCompanyId = _dbrOutput . _3 . _entityVal . _tutorialParticipantCompany . _Just - resultUser :: Lens' DailyTableData (Entity User) resultUser = _dbrOutput . _4 +resultUserAvs :: Traversal' DailyTableData UserAvs +resultUserAvs = _dbrOutput . _5 . _Just . _entityVal + resultCompanyId :: Traversal' DailyTableData CompanyId -resultCompanyId = _dbrOutput . _5 . _unValue . _Just +resultCompanyId = _dbrOutput . _6 . _unValue . _Just resultCourseQualis :: Traversal' DailyTableData [QualificationId] -resultCourseQualis = _dbrOutput . _6 . _unValue . _Just +resultCourseQualis = _dbrOutput . _7 . _unValue . _Just instance HasEntity DailyTableData User where @@ -151,22 +179,26 @@ instance HasEntity DailyTableData User where instance HasUser DailyTableData where hasUser = resultUser . _entityVal +-- see colRatedField' for an example of formCell usage + + mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do tuts <- getDayTutorials ssh (nd,nd) let dbtSQLQuery :: DailyTableExpr -> DailyTableOutput - dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do + dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs) = do EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser + EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser E.where_ $ tut E.^. TutorialId `E.in_` E.valList tuts let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId let cqQual = cq E.^. CourseQualificationQualification cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual] return $ E.arrayAggWith E.AggModeAll cqQual cqOrder - return (crs, tut, tpu, usr, selectCompanyUserPrime usr, associatedQualifications) + return (crs, tut, tpu, usr, avs, selectCompanyUserPrime usr, associatedQualifications) dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtProj = dbtProjId dbtColonnade = mconcat @@ -182,6 +214,7 @@ mkDailyTable isAdmin ssh nd = do , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin + , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn ] dbtSorting = Map.fromList [ sortUserNameLink queryUser @@ -190,6 +223,7 @@ mkDailyTable isAdmin ssh nd = do , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) , ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime) , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany)) + , ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo)) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 88982048b..b10815093 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -55,6 +55,98 @@ leftAssociativePairProjection constructor n i = do | w==i = conP constructor [wildP, varP x] | otherwise = conP constructor [pat x (pred w), wildP] +-- | Generic projections N-tuples that are actually left-associative pairs with differing constructors +-- i.e. @$(leftAssociativePairProjection [c1,c2,..,cn] m :: (..(t1 `c1` t2) `c2` .. `cn` t(n+1) -> tm@ (for m<=n+1) +leftAssociativeProjection :: [Name] -> Int -> ExpQ +leftAssociativeProjection constructors@(length -> n) (pred -> i) + | n < i = error $ "leftAssciativeProjection not given enough constructors: " <> show constructors + | otherwise = do + x <- newName "x" + lamE [pat x n] (varE x) + where + pat x 0 = varP x + pat x w@(pred -> v) + | w==i = conP (constructors !! v) [wildP, varP x] + | otherwise = conP (constructors !! v) [pat x v, wildP] + +-- Extract constructor names from a type definition of left-associative pair-constructors +-- PROBLEM: returns the wrong names: E.g. for `data LeftOuterJoinTC a b = a `LeftOuterJoinEC` b we get `LeftOuterJoinTC`, but we need `LeftOuterJoinEC` +extractConstructorNames :: Name -> Q [Name] +extractConstructorNames td = do + TyConI (TySynD _ [] ty) <- reify td + return (go ty) + where + go :: Type -> [Name] + go (AppT (AppT (ConT name) rest) _) = name : go rest + go _ = [] + +{- +Example: + +Suppose + type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + `E.InnerJoin` E.SqlExpr (Entity LmsUser) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) + ) +then + info <- reify ''LmsTableExpr +with + info = TyConI (TySynD Handler.Utils.LMS.LmsTableExpr [] + (AppT + (AppT + (ConT Database.Esqueleto.Internal.Internal.LeftOuterJoin) + (AppT + (AppT + (ConT Database.Esqueleto.Internal.Internal.InnerJoin) + (AppT + (AppT + (ConT Database.Esqueleto.Internal.Internal.InnerJoin) + (AppT + (ConT Database.Esqueleto.Internal.Internal.SqlExpr) + (AppT + (ConT Database.Persist.Class.PersistEntity.Entity) + (ConT Model.QualificationUser) + ) ) ) + (AppT (ConT Database.Esqueleto.Internal.Internal.SqlExpr) + (AppT + (ConT Database.Persist.Class.PersistEntity.Entity) + (ConT Model.User) + ) ) ) ) ) + (AppT + (ConT Database.Esqueleto.Internal.Internal.SqlExpr) + (AppT + (ConT Database.Persist.Class.PersistEntity.Entity) + (ConT Model.LmsUser) + ) ) ) ) + (AppT + (ConT Database.Esqueleto.Internal.Internal.SqlExpr) + (AppT + (ConT GHC.Maybe.Maybe) + (AppT + (ConT Database.Persist.Class.PersistEntity.Entity) + (ConT Model.QualificationUserBlock) + ) ) ) ) ) + + At this point we have the Type-Constructors, but we actually need the Data-Constructors. + We might possibly use something like the following: + + getDataConstructors :: Name -> Q [Name] + getDataConstructors conName = do + info <- reify conName + case info of + TyConI (DataD _ _ _ _ cons _) -> return $ concatMap getConNames cons + TyConI (NewtypeD _ _ _ _ con _) -> return $ getConNames con + _ -> return [] + + getConNames :: Con -> [Name] + getConNames (NormalC name _) = [name] + getConNames (RecC name _) = [name] + getConNames (InfixC _ name _) = [name] + getConNames (ForallC _ _ con) = getConNames con + getConNames _ = [] +-} + --------------- -- Functions -- diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index d8646159f..bafe207ae 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -744,10 +744,10 @@ fillDb = do for_ [jost] $ \uid -> void . insert' $ UserSchool uid avn False void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321 (n_day' $ -12) (Just "Some Message here") Nothing Nothing Nothing - void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing Nothing Nothing (readAvsFullCardNo "12345.6") void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing Nothing Nothing Nothing void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 now Nothing Nothing Nothing Nothing - void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing (readAvsFullCardNo "77777.7") void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 now Nothing Nothing Nothing Nothing let f_descr = Just $ htmlToStoredMarkup [shamlet|

        Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] From ac766ea2175895b57a6767f353e6a3987d9fe562 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 14 Oct 2024 19:16:36 +0200 Subject: [PATCH 044/187] refactor(TH): add sqlMIXproj' using reify on TableExpr for more comfort --- src/Database/Esqueleto/Utils/TH.hs | 2 +- src/Handler/School/DayTasks.hs | 20 ++++++--------- src/Utils/TH.hs | 40 +++++++++++++++++------------- 3 files changed, 31 insertions(+), 31 deletions(-) diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index f996ae160..b3eb51643 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -131,4 +131,4 @@ sqlMIXproj' :: Name -> Int -> ExpQ sqlMIXproj' t i = do ns <- extractConstructorNames t -- ns' <- maybeMapM (lookupValueName . nameBase) ns -- failed attempt change type-constructor names to identical expression-constructors - leftAssociativeProjection ns i + leftAssociativeProjection (reverse ns) i diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index f23b377bd..08f24cc72 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -105,12 +105,6 @@ type DailyTableExpr = `E.InnerJoin` E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserAvs)) ) --- due to GHC staging restrictions, we use the preprocessor instead -#define DAILY_TABLE_JOIN "IIIL" - --- force declarations before this point -$(return []) - type DailyTableOutput = E.SqlQuery ( E.SqlExpr (Entity Course) @@ -131,25 +125,25 @@ type DailyTableData = DBRow , E.Value (Maybe [QualificationId]) ) --- force declarations before this point +-- force declarations before this point to avoid staging restrictions $(return []) queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) -queryCourse = $(sqlMIXproj DAILY_TABLE_JOIN 1) +queryCourse = $(sqlMIXproj' ''DailyTableExpr 1) queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) -queryTutorial = $(sqlMIXproj DAILY_TABLE_JOIN 2) +queryTutorial = $(sqlMIXproj' ''DailyTableExpr 2) queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant) --- queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) -- TODO reify seems problematic for now -queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3) +queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) -- TODO reify seems problematic for now +-- queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3) queryUser :: DailyTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlMIXproj DAILY_TABLE_JOIN 4) +queryUser = $(sqlMIXproj' ''DailyTableExpr 4) queryUserAvs :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserAvs)) -queryUserAvs = $(sqlMIXproj DAILY_TABLE_JOIN 5) +queryUserAvs = $(sqlMIXproj' ''DailyTableExpr 5) resultCourse :: Lens' DailyTableData (Entity Course) resultCourse = _dbrOutput . _1 diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index b10815093..c8b14d704 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -74,12 +74,34 @@ leftAssociativeProjection constructors@(length -> n) (pred -> i) extractConstructorNames :: Name -> Q [Name] extractConstructorNames td = do TyConI (TySynD _ [] ty) <- reify td - return (go ty) + concatMapM getDataConstructors (go ty) where go :: Type -> [Name] go (AppT (AppT (ConT name) rest) _) = name : go rest go _ = [] + -- At this point we have the Type-Constructors, but we actually need the Data-Constructors. + -- We might possibly use something like the following: + + getDataConstructors :: Name -> Q [Name] + getDataConstructors conName = do + info <- reify conName + case info of + TyConI (DataD _ _ _ _ constr _) -> return $ concatMap getConNames constr + TyConI (NewtypeD _ _ _ _ constr _) -> return $ getConNames constr + _ -> return [] + + getConNames :: Con -> [Name] + getConNames (NormalC name _) = [name] + getConNames (RecC name _) = [name] + getConNames (InfixC _ name _) = [name] + getConNames (ForallC _ _ con) = getConNames con + getConNames _ = [] + + concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] + concatMapM f xs = concat <$> mapM f xs + + {- Example: @@ -128,23 +150,7 @@ with (ConT Model.QualificationUserBlock) ) ) ) ) ) - At this point we have the Type-Constructors, but we actually need the Data-Constructors. - We might possibly use something like the following: - getDataConstructors :: Name -> Q [Name] - getDataConstructors conName = do - info <- reify conName - case info of - TyConI (DataD _ _ _ _ cons _) -> return $ concatMap getConNames cons - TyConI (NewtypeD _ _ _ _ con _) -> return $ getConNames con - _ -> return [] - - getConNames :: Con -> [Name] - getConNames (NormalC name _) = [name] - getConNames (RecC name _) = [name] - getConNames (InfixC _ name _) = [name] - getConNames (ForallC _ _ con) = getConNames con - getConNames _ = [] -} From e8af2b8da9a939505d71b6175c1ab538a7985e6d Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 15 Oct 2024 11:03:01 +0200 Subject: [PATCH 045/187] refactor(TH): minor code clean up --- src/Database/Esqueleto/Utils/TH.hs | 13 ++++++------- src/Utils/TH.hs | 31 +++++++++++------------------- 2 files changed, 17 insertions(+), 27 deletions(-) diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index b3eb51643..6623220a6 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -26,6 +26,9 @@ import Data.List (foldr1, foldl) import Utils.TH import Control.Lens.Iso (Iso', iso) +{-# ANN module ("HLint: ignore Redundant bracket"::String) #-} + + class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool) @@ -125,10 +128,6 @@ sqlMIXproj = leftAssociativeProjection . map decodeJoin decodeJoin 'C' = 'E.CrossJoin decodeJoin c = error $ "Database.Esqueleto.Utils.TH.sqlMIXproj: received unknown SQL join kind \"" ++ c:"\"" -- always raised at compile time, so this is ok --- Alternative using `refiy`, but impractical due to TH staging restrictions --- and currently confuses type and expression constructors somehow +-- Alternative using `reify`; works, but may require `$(return [])` between type definition and call to workaround ghc staging problems sqlMIXproj' :: Name -> Int -> ExpQ -sqlMIXproj' t i = do - ns <- extractConstructorNames t - -- ns' <- maybeMapM (lookupValueName . nameBase) ns -- failed attempt change type-constructor names to identical expression-constructors - leftAssociativeProjection (reverse ns) i +sqlMIXproj' t i = extractConstructorNames t >>= flip leftAssociativeProjection i diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index c8b14d704..83e560af5 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -55,11 +55,11 @@ leftAssociativePairProjection constructor n i = do | w==i = conP constructor [wildP, varP x] | otherwise = conP constructor [pat x (pred w), wildP] --- | Generic projections N-tuples that are actually left-associative pairs with differing constructors +-- | Generic projections n-tuples that are actually left-associative pairs with differing constructors -- i.e. @$(leftAssociativePairProjection [c1,c2,..,cn] m :: (..(t1 `c1` t2) `c2` .. `cn` t(n+1) -> tm@ (for m<=n+1) leftAssociativeProjection :: [Name] -> Int -> ExpQ leftAssociativeProjection constructors@(length -> n) (pred -> i) - | n < i = error $ "leftAssciativeProjection not given enough constructors: " <> show constructors + | n < i = error $ "Util.TH.leftAssociativeProjection not given enough constructors: " <> show constructors | otherwise = do x <- newName "x" lamE [pat x n] (varE x) @@ -69,39 +69,32 @@ leftAssociativeProjection constructors@(length -> n) (pred -> i) | w==i = conP (constructors !! v) [wildP, varP x] | otherwise = conP (constructors !! v) [pat x v, wildP] --- Extract constructor names from a type definition of left-associative pair-constructors --- PROBLEM: returns the wrong names: E.g. for `data LeftOuterJoinTC a b = a `LeftOuterJoinEC` b we get `LeftOuterJoinTC`, but we need `LeftOuterJoinEC` +-- Extract constructor names from a type definition of left-associative pair-constructors (i.e. Esqueleto-Joins in a table-expression type) extractConstructorNames :: Name -> Q [Name] extractConstructorNames td = do - TyConI (TySynD _ [] ty) <- reify td - concatMapM getDataConstructors (go ty) + TyConI (TySynD _ [] ty) <- reify td -- executed at compile time, so failure is acceptable + reverse . concat <$> mapM getDataConstructors (go ty) where go :: Type -> [Name] go (AppT (AppT (ConT name) rest) _) = name : go rest go _ = [] - -- At this point we have the Type-Constructors, but we actually need the Data-Constructors. - -- We might possibly use something like the following: - + -- At this point we have the Type-Constructors, but we actually need the Data-Constructors: getDataConstructors :: Name -> Q [Name] getDataConstructors conName = do info <- reify conName case info of - TyConI (DataD _ _ _ _ constr _) -> return $ concatMap getConNames constr - TyConI (NewtypeD _ _ _ _ constr _) -> return $ getConNames constr + TyConI (DataD _ _ _ _ constr _) -> return $ concatMap getConNames constr + TyConI (NewtypeD _ _ _ _ constr _) -> return $ getConNames constr _ -> return [] getConNames :: Con -> [Name] - getConNames (NormalC name _) = [name] - getConNames (RecC name _) = [name] + getConNames (NormalC name _) = [name] + getConNames (RecC name _) = [name] getConNames (InfixC _ name _) = [name] getConNames (ForallC _ _ con) = getConNames con getConNames _ = [] - concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] - concatMapM f xs = concat <$> mapM f xs - - {- Example: @@ -149,8 +142,6 @@ with (ConT Database.Persist.Class.PersistEntity.Entity) (ConT Model.QualificationUserBlock) ) ) ) ) ) - - -} From 133a8d3739ae14d219b79c67cae7b098aa61700d Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 15 Oct 2024 17:48:36 +0200 Subject: [PATCH 046/187] chore(daily): show rooms for tutorial lessons --- src/Handler/School/DayTasks.hs | 48 +++++++++++++++++-- src/Handler/Utils/Occurrences.hs | 18 ++++++- src/Handler/Utils/Table/Cells.hs | 5 +- src/Handler/Utils/Widgets.hs | 7 +++ src/Model/Types/DateTime.hs | 6 +-- src/Model/Types/Room.hs | 2 +- src/Network/URI/Instances.hs | 5 +- src/Utils/Avs.hs | 2 +- src/Utils/Lens.hs | 4 ++ templates/exam-show.hamlet | 4 +- templates/widgets/lesson/set.hamlet | 11 +++++ templates/widgets/lesson/single.hamlet | 9 ++++ .../occurrence/cell/except-occur.hamlet | 10 ++-- test/Database/Fill.hs | 8 ++-- 14 files changed, 115 insertions(+), 24 deletions(-) create mode 100644 templates/widgets/lesson/set.hamlet create mode 100644 templates/widgets/lesson/single.hamlet diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 08f24cc72..5d44d8987 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -76,7 +76,7 @@ data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day) getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] getDayTutorials ssh dlimit@(dstart, dend ) | dstart > dend = return mempty - | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do + | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do candidates <- E.select $ do (trm :& crs :& tut) <- E.from $ E.table @Term `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) @@ -97,6 +97,40 @@ getDayTutorials ssh dlimit@(dstart, dend ) | otherwise = Nothing +-- Datatype to be used for memcaching occurrences +data LessonCacheKey = LessonCacheKeyTutorials SchoolId (Day,Day) + deriving (Eq, Ord, Read, Show, Generic) + deriving anyclass (Hashable, Binary) + + +-- | like getDayTutorials, but also returns the lessons occurring within the given time frame +getDayTutorials' :: SchoolId -> (Day,Day) -> DB (Map TutorialId [LessonTime]) +getDayTutorials' ssh dlimit@(dstart, dend ) + | dstart > dend = return mempty + | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (LessonCacheKeyTutorials ssh dlimit) $ do + candidates <- E.select $ do + (trm :& crs :& tut) <- E.from $ E.table @Term + `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) + `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) + E.where_ $ crs E.^. CourseSchool E.==. E.val ssh + E.&&. trm E.^. TermStart E.<=. E.val dend + E.&&. trm E.^. TermEnd E.>=. E.val dstart + return (trm, tut) + -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates + return $ foldMap checkCandidate candidates + where + checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId [LessonTime] + checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}) + | let lessons = Set.filter lessonFltr $ occurringLessons trm occ + , notNull lessons + = Map.singleton tutId $ Set.toAscList lessons -- due to Set not having a Functor instance, we need mostly need lists anyway + | otherwise + = mempty + + lessonFltr :: LessonTime -> Bool + lessonFltr LessonTime{..} = dstart <= localDay lessonStart + && dend >= localDay lessonEnd + type DailyTableExpr = ( E.SqlExpr (Entity Course) @@ -178,15 +212,16 @@ instance HasUser DailyTableData where mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do - tuts <- getDayTutorials ssh (nd,nd) + tutLessons <- getDayTutorials' ssh (nd,nd) let + tutIds = Map.keys tutLessons dbtSQLQuery :: DailyTableExpr -> DailyTableOutput dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs) = do EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser - E.where_ $ tut E.^. TutorialId `E.in_` E.valList tuts + E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId let cqQual = cq E.^. CourseQualificationQualification @@ -200,9 +235,14 @@ mkDailyTable isAdmin ssh nd = do sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row -> let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh} - = row ^. resultCourse . _entityVal + = row ^. resultCourse . _entityVal tutName = row ^. resultTutorial . _entityVal . _tutorialName in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName + , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons + , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) -> + -- listInlineCell (foldMap (fmap lessonRoom) $ Map.lookup tutId tutLessons) $ cellMaybe roomReferenceCell + -- listInlineCell (concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell + cellMaybe (`listInlineCell` roomReferenceCell) $ mapMM lessonRoom $ Map.lookup tutId tutLessons , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 3a5e511e1..9190f6abf 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -4,6 +4,7 @@ module Handler.Utils.Occurrences ( LessonTime(..) + , lessonTimeWidget, lessonTimesWidget , occurringLessons , occurrencesWidget , occurrencesCompute, occurrencesCompute' @@ -31,8 +32,8 @@ import Handler.Utils.Widgets (roomReferenceWidget) -- Model time intervals to compute lecture/tutorial lessons more intuitively -- -data LessonTime = LessonTime { lessonStart, lessonEnd :: LocalTime } - deriving (Eq, Ord, Read, Show, Generic) -- BEWARE: Ord instance might not be intuitive, but needed for Set +data LessonTime = LessonTime { lessonStart, lessonEnd :: LocalTime, lessonRoom :: Maybe RoomReference } + deriving (Eq, Ord, Show, Generic, Binary) -- BEWARE: Ord instance might not be intuitive, but needed for Set occurringLessons :: Term -> Occurrences -> Set LessonTime occurringLessons term Occurrences{..} = Set.union exceptOcc $ Set.filter isExcept scheduledLessons @@ -48,6 +49,7 @@ occurrenceScheduleToLessons Term{..} = let occDays = daysOfWeekBetween (termLectureStart, termLectureEnd) scheduleDayOfWeek \\ setHolidays toLesson d = LessonTime { lessonStart = LocalTime d scheduleStart , lessonEnd = LocalTime d scheduleEnd + , lessonRoom = scheduleRoom } in Set.map toLesson occDays @@ -57,11 +59,23 @@ occurrenceExceptionToLessons = Set.foldr aux mempty aux ExceptOccur{..} (oc,no) = let t = LessonTime { lessonStart = LocalTime exceptDay exceptStart , lessonEnd = LocalTime exceptDay exceptEnd + , lessonRoom = exceptRoom } in (Set.insert t oc,no) aux ExceptNoOccur{..} (oc,no) = (oc, Set.insert exceptTime no) +lessonTimeWidget :: Bool -> LessonTime -> Widget +lessonTimeWidget roomHidden LessonTime{..} = do + lStart <- formatTime SelFormatTime lessonStart + lEnd <- formatTime SelFormatTime lessonEnd + $(widgetFile "widgets/lesson/single") + +lessonTimesWidget :: (Traversable t, MonoFoldable (t Widget)) => Bool -> t LessonTime -> Widget +lessonTimesWidget roomHidden lessonsSet = do + let lessons = lessonTimeWidget roomHidden <$> lessonsSet + $(widgetFile "widgets/lesson/set") + ----------------- -- Occurrences -- diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 0d43a13fe..85f1fc68e 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -510,11 +510,14 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc +lessonTimesCell :: IsDBTable m a => Bool -> [LessonTime] -> DBCell m a +lessonTimesCell roomHidden lessons = cell $ lessonTimesWidget roomHidden lessons + occurrencesCell :: IsDBTable m a => Bool -> JSONB Occurrences -> DBCell m a occurrencesCell roomHidden occs = cell $ occurrencesWidget roomHidden occs roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a -roomReferenceCell = cell . roomReferenceWidget +roomReferenceCell = cell . roomReferenceShortWidget cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index fc5c7bfc0..fe93cc9c8 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -299,6 +299,13 @@ roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-referen linkText = uriToString id roomRefLink mempty instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal") +roomReferenceShortWidget :: RoomReference -> Widget +roomReferenceShortWidget RoomReferenceSimple{..} = text2widget roomRefText +roomReferenceShortWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference/link") + where + linkText = uriToString id roomRefLink mempty + instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal") + ---------- -- JSON -- diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 55ec90530..abc157295 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -170,7 +170,7 @@ data OccurrenceSchedule = ScheduleWeekly , scheduleEnd :: TimeOfDay , scheduleRoom :: Maybe RoomReference } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic,Binary) deriving anyclass (NFData) deriveJSON defaultOptions @@ -189,7 +189,7 @@ data OccurrenceException = ExceptOccur | ExceptNoOccur { exceptTime :: LocalTime } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic,Binary) deriving anyclass (NFData) -- Handler.Utils.Occurrences.occurrencesAddBusinessDays assumes that OccurrenceException is ordered chronologically @@ -221,7 +221,7 @@ data Occurrences = Occurrences { occurrencesScheduled :: Set OccurrenceSchedule , occurrencesExceptions :: Set OccurrenceException } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, Binary) deriving anyclass (NFData) deriveJSON defaultOptions diff --git a/src/Model/Types/Room.hs b/src/Model/Types/Room.hs index 0db43e887..4fcd6ddbd 100644 --- a/src/Model/Types/Room.hs +++ b/src/Model/Types/Room.hs @@ -19,7 +19,7 @@ data RoomReference { roomRefLink :: URI , roomRefInstructions :: Maybe StoredMarkup } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, Binary) deriving anyclass (NFData) deriveJSON defaultOptions diff --git a/src/Network/URI/Instances.hs b/src/Network/URI/Instances.hs index 15097ea6d..065765647 100644 --- a/src/Network/URI/Instances.hs +++ b/src/Network/URI/Instances.hs @@ -18,6 +18,7 @@ import Data.Swagger import Data.Swagger.Internal.Schema import Data.Proxy +import Data.Binary import Servant.Docs @@ -28,6 +29,8 @@ import Control.Monad.Fail (MonadFail(..)) import Database.Persist import Database.Persist.Sql +deriving instance Binary URIAuth +deriving instance Binary URI instance ToHttpApiData URI where toQueryParam = pack . ($ mempty) . uriToString id @@ -54,7 +57,7 @@ instance Aeson.FromJSON URI where parseJSON = Aeson.withText "URI" $ maybe (fail "Could not parse URI") return . parseURIReference . unpack instance PersistField URI where - toPersistValue = PersistText . pack . ($ mempty) . uriToString id + toPersistValue = PersistText . pack . ($ mempty) . uriToString id fromPersistValue (PersistText t) = maybe (Left "Could not parse URI") return . parseURIReference $ unpack t fromPersistValue v = Left $ "Failed to parse Haskell type `URI`; expected text from database but received: " <> tshow v <> "." instance PersistFieldSql URI where diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index f9f276c2f..531821433 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -86,7 +86,7 @@ mkAvsQuery _ _ _ = AvsQuery fakePerson :: AvsQueryPerson -> AvsResponsePerson fakePerson = let - sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty + sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) $ Set.singleton $ AvsDataPersonCard True Nothing Nothing AvsCardColorRot mempty Nothing Nothing Nothing Nothing (AvsCardNo "424242") "8" stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) mempty steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty sumpfi1 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index eaff72ba0..7ab25710a 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -93,6 +93,10 @@ _Integral = iso fromIntegral fromIntegral _not :: Iso' Bool Bool _not = iso not not +instance Wrapped (JSONB a) where + type Unwrapped (JSONB a) = a + _Wrapped' = iso unJSONB JSONB + ----------------------------------- -- Lens Definitions for our Types diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index a21e0f57b..73177a5e2 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -86,7 +86,7 @@ $maybe desc <- examDescription ^{notificationPersonalIdentification} $maybe room <- examRoom

        _{MsgExamRoom} -
        ^{roomReferenceWidget room} +
        ^{roomReferenceShortWidget room} $if examTimes
        _{MsgTableExamTime}
        @@ -243,7 +243,7 @@ $if not (null occurrences) $if showRoom $maybe room <- examOccurrenceRoom - ^{roomReferenceWidget room} + ^{roomReferenceShortWidget room} $nothing _{MsgExamOccurrenceRoomIsUnset} $else diff --git a/templates/widgets/lesson/set.hamlet b/templates/widgets/lesson/set.hamlet new file mode 100644 index 000000000..b42ff8ae0 --- /dev/null +++ b/templates/widgets/lesson/set.hamlet @@ -0,0 +1,11 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +$if not (null lessons) +
          + $forall lsn <- lessons +
        • + ^{lsn} diff --git a/templates/widgets/lesson/single.hamlet b/templates/widgets/lesson/single.hamlet new file mode 100644 index 000000000..ba02be0a6 --- /dev/null +++ b/templates/widgets/lesson/single.hamlet @@ -0,0 +1,9 @@ +$newline never + +$# SPDX-FileCopyrightText: 20 24 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +#{lStart}–#{lEnd} +$if not roomHidden + \ ^{foldMap roomReferenceWidget lessonRoom} diff --git a/templates/widgets/occurrence/cell/except-occur.hamlet b/templates/widgets/occurrence/cell/except-occur.hamlet index f17dbce9d..5551a5e9f 100644 --- a/templates/widgets/occurrence/cell/except-occur.hamlet +++ b/templates/widgets/occurrence/cell/except-occur.hamlet @@ -4,9 +4,9 @@ $# SPDX-FileCopyrightText: 2022 Gregor Kleen $# $# SPDX-License-Identifier: AGPL-3.0-or-later -$if not (null occurrencesScheduled') - _{MsgExceptionKindOccur} #{exceptStart'}–#{exceptEnd'} - $if not roomHidden - ^{foldMap roomReferenceWidget exceptRoom} -$else +$if null occurrencesScheduled' #{exceptStart'}–#{exceptEnd'} +$else + _{MsgExceptionKindOccur} #{exceptStart'}–#{exceptEnd'} +$if not roomHidden + \ ^{foldMap roomReferenceWidget exceptRoom} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index bafe207ae..bf491d3a8 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -744,8 +744,8 @@ fillDb = do for_ [jost] $ \uid -> void . insert' $ UserSchool uid avn False void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321 (n_day' $ -12) (Just "Some Message here") Nothing Nothing Nothing - void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing Nothing Nothing (readAvsFullCardNo "12345.6") - void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 99) svaupel 99 (n_day' $ -22) Nothing Nothing Nothing (readAvsFullCardNo "444444.4") + void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing Nothing Nothing (readAvsFullCardNo "5555.5") void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 now Nothing Nothing Nothing Nothing void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing (readAvsFullCardNo "77777.7") void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 now Nothing Nothing Nothing Nothing @@ -1102,13 +1102,13 @@ fillDb = do { exceptDay = nTimes 8 succ secondDay , exceptStart = TimeOfDay 9 0 0 , exceptEnd = TimeOfDay 16 0 0 - , exceptRoom = Just $ RoomReferenceSimple "B747" + , exceptRoom = Nothing } , ExceptOccur { exceptDay = nowaday , exceptStart = TimeOfDay 9 10 0 , exceptEnd = TimeOfDay 16 10 0 - , exceptRoom = Nothing + , exceptRoom = Just $ RoomReferenceSimple "B747" } ] } From 4934f5f89d3084573590ab43c15b7a14aa8f3eff Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 17 Oct 2024 16:48:09 +0200 Subject: [PATCH 047/187] fix(room): deduplicate room column and fix order --- src/Handler/School/DayTasks.hs | 8 ++++---- src/Handler/Utils/Table/Pagination.hs | 10 +++++----- test/Database/Fill.hs | 20 ++++++++++++++++---- 3 files changed, 25 insertions(+), 13 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 5d44d8987..1d0abd4c9 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -42,7 +42,7 @@ instance Finite DailyTableAction nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''DailyTableAction id -data DailyTableActionData = DailyActDummyData +data DailyTableActionData = DailyActDummyData deriving (Eq, Ord, Read, Show, Generic) -- | partial JSON object to be used for filtering with "@>" @@ -240,9 +240,9 @@ mkDailyTable isAdmin ssh nd = do in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) -> - -- listInlineCell (foldMap (fmap lessonRoom) $ Map.lookup tutId tutLessons) $ cellMaybe roomReferenceCell - -- listInlineCell (concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell - cellMaybe (`listInlineCell` roomReferenceCell) $ mapMM lessonRoom $ Map.lookup tutId tutLessons + -- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell + cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons + -- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index d1c449fde..54df04a3c 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1854,19 +1854,19 @@ maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ toWidget $ x2widgetUnauth Nothing -listInlineCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a +listInlineCell :: (IsDBTable m a, MonoFoldable mono, SemiSequence mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a listInlineCell = listInlineCell' . return -listInlineCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a +listInlineCell' :: (IsDBTable m a, MonoFoldable mono, SemiSequence mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a listInlineCell' mkXS mkCell = ilistInlineCell' (otoList <$> mkXS) $ const mkCell -ilistInlineCell :: (IsDBTable m a, MonoFoldableWithKey mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a +ilistInlineCell :: (IsDBTable m a, MonoFoldableWithKey mono, SemiSequence mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a ilistInlineCell = ilistInlineCell' . return -ilistInlineCell' :: (IsDBTable m a, MonoFoldableWithKey mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a +ilistInlineCell' :: (IsDBTable m a, MonoFoldableWithKey mono, SemiSequence mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a ilistInlineCell' mkXS mkCell = review dbCell . ([], ) $ do xs <- mkXS - cells <- forM (otoKeyedList xs) $ + cells <- forM (otoKeyedList $ reverse xs) $ -- Do we need to reverse for all MonoFoldableWithKey, or is only the List-Instance flawed? \(view dbCell . uncurry mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget return $(widgetFile "table/cell/listInline") diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index bf491d3a8..1ea12d27e 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1084,6 +1084,12 @@ fillDb = do , scheduleEnd = TimeOfDay 14 44 0 , scheduleRoom = Just $ RoomReferenceSimple "A320neo" } + , ScheduleWeekly + { scheduleDayOfWeek = Friday + , scheduleStart = TimeOfDay 15 55 0 + , scheduleEnd = TimeOfDay 16 16 0 + , scheduleRoom = Just $ RoomReferenceSimple "A340" + } , ScheduleWeekly { scheduleDayOfWeek = Sunday , scheduleStart = TimeOfDay 15 55 0 @@ -1094,8 +1100,8 @@ fillDb = do , occurrencesExceptions = Set.fromList [ ExceptOccur { exceptDay = nTimes 7 succ firstDay - , exceptStart = TimeOfDay 8 30 0 - , exceptEnd = TimeOfDay 16 0 0 + , exceptStart = TimeOfDay 8 30 30 + , exceptEnd = TimeOfDay 16 0 30 , exceptRoom = Just $ RoomReferenceSimple "A380" } , ExceptOccur @@ -1107,7 +1113,13 @@ fillDb = do , ExceptOccur { exceptDay = nowaday , exceptStart = TimeOfDay 9 10 0 - , exceptEnd = TimeOfDay 16 10 0 + , exceptEnd = TimeOfDay 12 10 0 + , exceptRoom = Just $ RoomReferenceSimple "B747" + } + , ExceptOccur + { exceptDay = nowaday + , exceptStart = TimeOfDay 13 11 0 + , exceptEnd = TimeOfDay 16 11 0 , exceptRoom = Just $ RoomReferenceSimple "B747" } ] @@ -1152,7 +1164,7 @@ fillDb = do { exceptDay = nowaday , exceptStart = TimeOfDay 17 10 0 , exceptEnd = TimeOfDay 18 10 0 - , exceptRoom = Nothing + , exceptRoom = Just $ RoomReferenceSimple "A380" } ] } From fba0b71d503a917ab320120b18be85a45d992724 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 21 Oct 2024 15:59:32 +0200 Subject: [PATCH 048/187] chore(tutorial): build model for #90 --- models/tutorials.model | 20 +++++++++---- models/users.model | 7 ++++- src/Handler/Course/ParticipantInvite.hs | 3 ++ src/Handler/Course/Users.hs | 2 +- src/Handler/Tutorial/Register.hs | 2 +- src/Handler/Utils/Users.hs | 38 ++++++++++++++++++++++++- src/Model/Types/User.hs | 38 +++++++++++++++++++++++-- src/Utils/Lens.hs | 2 ++ test/Database/Fill.hs | 15 ++++++---- 9 files changed, 110 insertions(+), 17 deletions(-) diff --git a/models/tutorials.model b/models/tutorials.model index 72dc8676a..c1e237344 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -24,9 +24,19 @@ Tutor UniqueTutor tutorial user deriving Generic TutorialParticipant - tutorial TutorialId OnDeleteCascade OnUpdateCascade - user UserId - company CompanyId Maybe + tutorial TutorialId OnDeleteCascade OnUpdateCascade + user UserId + company CompanyId Maybe + drivingPermit UserDrivingPermit Maybe + eyeExam UserEyeExam Maybe + note Text Maybe UniqueTutorialParticipant tutorial user - deriving Eq Ord Show - deriving Generic \ No newline at end of file + deriving Eq Ord Show Generic +TutorialParticipantDay + tutorial TutorialId OnDeleteCascade OnUpdateCascade + user UserId OnDeleteCascade OnUpdateCascade + day Day + attendance Bool default=true + note Text Maybe + UniqueTutorialParticipantDay tutorial user day + deriving Show Generic \ No newline at end of file diff --git a/models/users.model b/models/users.model index beb1d8e0c..96761a200 100644 --- a/models/users.model +++ b/models/users.model @@ -104,4 +104,9 @@ UserSupervisor reason Text Maybe -- miscellaneous reason, e.g. Winterservice supervisision UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once) deriving Generic Show - +UserDay + user UserId OnDeleteCascade OnUpdateCascade + day Day + parkingToken Bool default=false + UniqueUserDay user day + deriving Generic Show diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index dfb456147..665d83627 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -402,6 +402,9 @@ registerTutorialMembers tutId (Set.toList -> users) = runDB $ do prevParticipants <- Set.fromList . fmap entityKey <$> selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] [] participants <- fmap Set.fromList . for users $ \tutorialParticipantUser -> do tutorialParticipantCompany <- selectCompanyUserPrime' tutorialParticipantUser + let tutorialParticipantDrivingPermit = Nothing + tutorialParticipantEyeExam = Nothing + tutorialParticipantNote = Nothing Entity tutPartId _ <- upsert TutorialParticipant { tutorialParticipantTutorial = tutId, .. } [] audit $ TransactionTutorialParticipantEdit tutId tutPartId tutorialParticipantUser return tutPartId diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 3d66e30c7..b5fe6ca51 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -736,7 +736,7 @@ postCUsersR tid ssh csh = do (CourseUserRegisterTutorialData{..}, selectedUsers) -> do Sum nrOk <- runDB $ flip foldMapM selectedUsers $ \uid -> do fsh <- selectCompanyUserPrime' uid - mbKey <- insertUnique $ TutorialParticipant registerTutorial uid fsh + mbKey <- insertUnique $ TutorialParticipant registerTutorial uid fsh Nothing Nothing Nothing return $ Sum $ length mbKey let mStatus = bool Success Warning $ nrOk < Set.size selectedUsers addMessageI mStatus $ MsgCourseUsersTutorialRegistered $ fromIntegral nrOk diff --git a/src/Handler/Tutorial/Register.hs b/src/Handler/Tutorial/Register.hs index 0377aae60..1db091e07 100644 --- a/src/Handler/Tutorial/Register.hs +++ b/src/Handler/Tutorial/Register.hs @@ -24,7 +24,7 @@ postTRegisterR tid ssh csh tutn = do BtnRegister -> do ok <- runDB $ do fsh <- selectCompanyUserPrime' uid - insertUnique $ TutorialParticipant tutid uid fsh + insertUnique $ TutorialParticipant tutid uid fsh Nothing Nothing Nothing if isJust ok then addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName else addMessageI Error $ MsgTutorialRegisteredFail tutorialName -- cannot happen, but it is nonetheless better to be safe than crashing diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 1760d37fe..86d3f40df 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -871,9 +871,30 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<# (tutorialParticipant E.^. TutorialParticipantTutorial) E.<&> E.val newUserId E.<&> (tutorialParticipant E.^. TutorialParticipantCompany) + E.<&> (tutorialParticipant E.^. TutorialParticipantDrivingPermit) + E.<&> (tutorialParticipant E.^. TutorialParticipantEyeExam) + E.<&> (tutorialParticipant E.^. TutorialParticipantNote) ) (\_current _excluded -> []) - deleteWhere [ TutorialParticipantUser ==. oldUserId ] + E.insertSelectWithConflict + UniqueTutorialParticipantDay + (EL.from $ \tutorialParticipantDay -> do + E.where_ $ tutorialParticipantDay E.^. TutorialParticipantDayUser E.==. E.val oldUserId + return $ TutorialParticipantDay + E.<# (tutorialParticipantDay E.^. TutorialParticipantDayTutorial) + E.<&> E.val newUserId + E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayDay) + E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayAttendance) + E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayNote) + ) + (\current excluded -> + [ TutorialParticipantDayAttendance E.=. (current E.^. TutorialParticipantDayAttendance E.||. excluded E.^. TutorialParticipantDayAttendance) + , TutorialParticipantDayNote E.=. E.coalesce [current E.^. TutorialParticipantDayNote, excluded E.^. TutorialParticipantDayNote] + ] + ) + deleteWhere [ TutorialParticipantDayUser ==. oldUserId ] + deleteWhere [ TutorialParticipantUser ==. oldUserId ] + E.insertSelectWithConflict UniqueSystemMessageHidden @@ -1012,6 +1033,21 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do ) deleteWhere [ UserCompanyUser ==. oldUserId] + E.insertSelectWithConflict + UniqueUserDay + (EL.from $ \userDay -> do + E.where_ $ userDay E.^. UserDayUser E.==. E.val oldUserId + return $ UserDay + E.<# E.val newUserId + E.<&> (userDay E.^. UserDayDay) + E.<&> (userDay E.^. UserDayParkingToken) + ) + (\current excluded -> + [ UserDayParkingToken E.=. (current E.^. UserDayParkingToken E.||. excluded E.^. UserDayParkingToken) + ] + ) + deleteWhere [ UserDayUser ==. oldUserId] + mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId case (mbOldAvsId,mbNewAvsId) of diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs index 64cb539d9..d2143636c 100644 --- a/src/Model/Types/User.hs +++ b/src/Model/Types/User.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -15,7 +15,7 @@ data SystemFunction = SystemExamOffice | SystemFaculty | SystemStudent - | SystemPrinter + | SystemPrinter deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite, Hashable, NFData) @@ -24,3 +24,37 @@ pathPieceJSON ''SystemFunction pathPieceJSONKey ''SystemFunction derivePersistFieldPathPiece ''SystemFunction pathPieceBinary ''SystemFunction + + + +-------------------------------------------------------------------------------------- +-- User related dataypes which are not stored in User itself, but in various places + +data UserDrivingPermit = UserDrivingPermitB + | UserDrivingPermitB01 + deriving (Eq, Ord, Enum, Bounded, Generic, Universe, Finite, Hashable, NFData) + +instance Show UserDrivingPermit where + show UserDrivingPermitB = "B" + show UserDrivingPermitB01 = "B01" + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 3 + } ''UserDrivingPermit +derivePersistFieldJSON ''UserDrivingPermit + + +data UserEyeExam = UserEyeExamSX + | UserEyeExamS01 + deriving (Eq, Ord, Enum, Bounded, Generic, Universe, Finite, Hashable, NFData) + +instance Show UserEyeExam where + show UserEyeExamSX = "SX" + show UserEyeExamS01 = "S01" + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 3 + } ''UserEyeExam +derivePersistFieldJSON ''UserEyeExam + + diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 7ab25710a..46f8d5000 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -136,6 +136,7 @@ makeClassyFor_ ''LmsUser makeClassyFor_ ''LmsReport makeClassyFor_ ''UserAvs +makeLenses_ ''UserDay makeLenses_ ''UserCompany makeLenses_ ''Company @@ -286,6 +287,7 @@ makeLenses_ ''CourseNewsFile makeLenses_ ''Tutorial makeLenses_ ''TutorialParticipant +makeLenses_ ''TutorialParticipantDay makeLenses_ ''SessionFile diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 1ea12d27e..5f95fbab1 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1217,12 +1217,15 @@ fillDb = do insert_ $ CourseParticipant c gkleen now $ CourseParticipantInactive True insert_ $ CourseParticipant c fhamann now $ CourseParticipantInactive False insert_ $ CourseParticipant c svaupel now CourseParticipantActive - insert_ $ TutorialParticipant tut1 svaupel Nothing - insert_ $ TutorialParticipant tut2 svaupel $ Just fraGround - when (odd tyear) $ insert_ $ TutorialParticipant tut3 svaupel $ Just fraGround - insert_ $ TutorialParticipant tut1 gkleen $ Just nice - insert_ $ TutorialParticipant tut2 fhamann $ Just bpol - when (even tyear) $ insert_ $ TutorialParticipant tut3 jost $ Just fraportAg + insert_ $ TutorialParticipant tut1 svaupel Nothing Nothing Nothing Nothing + insert_ $ TutorialParticipant tut2 svaupel (Just fraGround) (Just UserDrivingPermitB01) (Just UserEyeExamS01) (Just "Testnote") + when (odd tyear) $ insert_ $ TutorialParticipant tut3 svaupel (Just fraGround) Nothing Nothing Nothing + insert_ $ TutorialParticipant tut1 gkleen (Just nice) (Just UserDrivingPermitB) (Just UserEyeExamSX) (Just "Note test") + insert_ $ TutorialParticipant tut2 fhamann (Just bpol) (Just UserDrivingPermitB) (Just UserEyeExamSX) (Just "All ok") + when (even tyear) $ insert_ $ TutorialParticipant tut3 jost (Just fraportAg) (Just UserDrivingPermitB01) (Just UserEyeExamSX) (Just "Eye test suspicious") + insert_ $ TutorialParticipantDay tut2 svaupel nowaday True $ Just "Was on time" + insert_ $ TutorialParticipantDay tut2 fhamann nowaday False $ Just "Missing" + when (odd tyear) $ void . insert' $ Exam { examCourse = c From 2fdb132140bb3985dede7c0458148132151293b1 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 22 Oct 2024 12:39:34 +0200 Subject: [PATCH 049/187] chore(tutorial): show additional columns for #90 columns are distinguished by user and the entities given in parenthesis: - driving permit (tutorial) - eye exam (tutrial) - tutorial note (tutorial) - attendance (tutorial & day) - attendance-note (tutorial & day) - parking permit (day) --- .../courses/tutorial/de-de-formal.msg | 9 +++- .../categories/courses/tutorial/en-eu.msg | 7 ++- .../utils/table_column/de-de-formal.msg | 5 +- messages/uniworx/utils/table_column/en-eu.msg | 5 +- src/Handler/School/DayTasks.hs | 50 ++++++++++++++++--- test/Database/Fill.hs | 2 + 6 files changed, 64 insertions(+), 14 deletions(-) diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index b0e631340..4311bf005 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Winnie Ros +# SPDX-FileCopyrightText: 2022-24 Winnie Ros , Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -50,4 +50,9 @@ TutorialUserGrantQualification: Qualifikation vergeben TutorialUserRenewQualification: Qualifikation regulär verlängern TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben -CommTutorial: Kursmitteilung \ No newline at end of file +CommTutorial: Kursmitteilung +TutorialDrivingPermit: Führerschein +TutorialEyeExam: Sehtest +TutorialNote: Kursnotiz +TutorialDayAttendance day@Text: Anwesenheit am #{day} +TutorialDayNote day@Text: Anwesenheitsnotiz für #{day} \ No newline at end of file diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index a3afdf94f..407bb1b88 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Winnie Ros +# SPDX-FileCopyrightText: 2022-24 Winnie Ros , Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -52,3 +52,8 @@ TutorialUserRenewQualification: Renew qualification TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} course #{pluralEN n "user" "users"} TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} course #{pluralEN n "user" "users"} CommTutorial: Course message +TutorialDrivingPermit: Driving permit +TutorialEyeExam: Eye exam +TutorialNote: Course note +TutorialDayAttendance day: Attendance #{day} +TutorialDayNote day: Attendance note #{day} \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index f3cc58366..ee6890725 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros , Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -117,4 +117,5 @@ TableFilterCommaPlusShort: Unterstützt mehrere Kriterien mit Komma-Plus, siehe TableFilterCommaName: Mehrere Namen mit Komma trennen. TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. TableUserEdit: Benutzer bearbeiten -TableRows: Zeilen \ No newline at end of file +TableRows: Zeilen +TableUserParkingToken: Parkmarke \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 65eb98114..0ecdd9a0a 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost ,Winnie Ros , Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -117,4 +117,5 @@ TableFilterCommaPlusShort: Support multiple criteria with comma/plus, see above. TableFilterCommaName: Separate names by comma. TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. TableUserEdit: Edit user -TableRows: Rows \ No newline at end of file +TableRows: Rows +TableUserParkingToken: Parking token \ No newline at end of file diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 1d0abd4c9..c9b156e5f 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -138,6 +138,8 @@ type DailyTableExpr = `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) `E.InnerJoin` E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserAvs)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserDay)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity TutorialParticipantDay)) ) type DailyTableOutput = E.SqlQuery @@ -146,6 +148,8 @@ type DailyTableOutput = E.SqlQuery , E.SqlExpr (Entity TutorialParticipant) , E.SqlExpr (Entity User) , E.SqlExpr (Maybe (Entity UserAvs)) + , E.SqlExpr (Maybe (Entity UserDay)) + , E.SqlExpr (Maybe (Entity TutorialParticipantDay)) , E.SqlExpr (E.Value (Maybe CompanyId)) , E.SqlExpr (E.Value (Maybe [QualificationId])) ) @@ -155,6 +159,8 @@ type DailyTableData = DBRow , Entity TutorialParticipant , Entity User , Maybe (Entity UserAvs) + , Maybe (Entity UserDay) + , Maybe (Entity TutorialParticipantDay) , E.Value (Maybe CompanyId) , E.Value (Maybe [QualificationId]) ) @@ -179,6 +185,12 @@ queryUser = $(sqlMIXproj' ''DailyTableExpr 4) queryUserAvs :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserAvs)) queryUserAvs = $(sqlMIXproj' ''DailyTableExpr 5) +queryUserDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserDay)) +queryUserDay = $(sqlMIXproj' ''DailyTableExpr 6) + +queryParticipantDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity TutorialParticipantDay)) +queryParticipantDay = $(sqlMIXproj' ''DailyTableExpr 7) + resultCourse :: Lens' DailyTableData (Entity Course) resultCourse = _dbrOutput . _1 @@ -194,11 +206,17 @@ resultUser = _dbrOutput . _4 resultUserAvs :: Traversal' DailyTableData UserAvs resultUserAvs = _dbrOutput . _5 . _Just . _entityVal +resultUserDay :: Traversal' DailyTableData UserDay +resultUserDay = _dbrOutput . _6 . _Just . _entityVal + +resultParticipantDay :: Traversal' DailyTableData TutorialParticipantDay +resultParticipantDay = _dbrOutput . _7 . _Just . _entityVal + resultCompanyId :: Traversal' DailyTableData CompanyId -resultCompanyId = _dbrOutput . _6 . _unValue . _Just +resultCompanyId = _dbrOutput . _8 . _unValue . _Just resultCourseQualis :: Traversal' DailyTableData [QualificationId] -resultCourseQualis = _dbrOutput . _7 . _unValue . _Just +resultCourseQualis = _dbrOutput . _9 . _unValue . _Just instance HasEntity DailyTableData User where @@ -213,21 +231,27 @@ instance HasUser DailyTableData where mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do tutLessons <- getDayTutorials' ssh (nd,nd) + dday <- formatTime SelFormatDate nd let tutIds = Map.keys tutLessons dbtSQLQuery :: DailyTableExpr -> DailyTableOutput - dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs) = do - EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId - EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial - EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser + dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do + EL.on $ tut E.^. TutorialId E.=?. tdy E.?. TutorialParticipantDayTutorial + E.&&. usr E.^. UserId E.=?. tdy E.?. TutorialParticipantDayUser + E.&&. E.val nd E.=?. tdy E.?. TutorialParticipantDayDay + EL.on $ usr E.^. UserId E.=?. udy E.?. UserDayUser + E.&&. E.val nd E.=?. udy E.?. UserDayDay EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser + EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser + EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial + EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId let cqQual = cq E.^. CourseQualificationQualification cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual] return $ E.arrayAggWith E.AggModeAll cqQual cqOrder - return (crs, tut, tpu, usr, avs, selectCompanyUserPrime usr, associatedQualifications) + return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications) dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtProj = dbtProjId dbtColonnade = mconcat @@ -249,6 +273,12 @@ mkDailyTable isAdmin ssh nd = do , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn + , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> maybeCell x $ textCell . tshow + , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> maybeCell x $ textCell . tshow + , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> maybeCell x textCell + , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> maybeCell x tickmarkCell + , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> maybeCell x textCell + , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell ] dbtSorting = Map.fromList [ sortUserNameLink queryUser @@ -258,6 +288,12 @@ mkDailyTable isAdmin ssh nd = do , ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime) , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany)) , ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo)) + , ("permit" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit)) + , ("eye-exam" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam)) + , ("note-tutorial" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantNote)) + , ("attendance" , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance)) + , ("note-attend" , SortColumn $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote)) + , ("parking" , SortColumnNullsInv $ queryUserDay >>> (E.?. UserDayParkingToken)) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 5f95fbab1..312057cfb 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1256,6 +1256,8 @@ fillDb = do , examStaff = Just "Jost" , examAuthorshipStatement = Nothing } + insert_ $ UserDay svaupel nowaday True + insert_ $ UserDay fhamann nowaday False testMsg <- insert SystemMessage { systemMessageNewsOnly = False From 02d10006fcc798de2aa955a2d81d1e6cad38dcbb Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 22 Oct 2024 14:39:58 +0200 Subject: [PATCH 050/187] fix(build) --- src/Handler/School/DayTasks.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index c9b156e5f..c523eb3c3 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -252,7 +252,7 @@ mkDailyTable isAdmin ssh nd = do cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual] return $ E.arrayAggWith E.AggModeAll cqQual cqOrder return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications) - dbtRowKey = queryTutorial >>> (E.^. TutorialId) + dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId) dbtProj = dbtProjId dbtColonnade = mconcat [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) From 85511091cca46e6ec5ee6f73f661e47b8d0aac19 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 23 Oct 2024 15:47:20 +0200 Subject: [PATCH 051/187] fix(test): fix test problem and add tests for UserEyeExam and UserDrivingPermit --- src/Model/Types/User.hs | 8 ++++++-- test/Handler/Utils/SubmissionSpec.hs | 2 +- test/Model/TypesSpec.hs | 25 +++++++++++++++++++++++++ test/Utils/TypesSpec.hs | 22 +++++++++++----------- 4 files changed, 43 insertions(+), 14 deletions(-) diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs index d2143636c..b7fec9225 100644 --- a/src/Model/Types/User.hs +++ b/src/Model/Types/User.hs @@ -38,6 +38,9 @@ instance Show UserDrivingPermit where show UserDrivingPermitB = "B" show UserDrivingPermitB01 = "B01" +instance RenderMessage a UserDrivingPermit where + renderMessage _foundation _languages = tshow + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } ''UserDrivingPermit @@ -52,9 +55,10 @@ instance Show UserEyeExam where show UserEyeExamSX = "SX" show UserEyeExamS01 = "S01" +instance RenderMessage a UserEyeExam where + renderMessage _foundation _languages = tshow + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } ''UserEyeExam derivePersistFieldJSON ''UserEyeExam - - diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs index 402e9fc9b..f1ef2ba5e 100644 --- a/test/Handler/Utils/SubmissionSpec.hs +++ b/test/Handler/Utils/SubmissionSpec.hs @@ -196,7 +196,7 @@ spec = withApp . describe "Submission distribution" $ do void . insert $ Tutor tutId sheetCorrectorUser E.insertSelect . E.from $ \submissionUser -> do E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId - return $ TutorialParticipant E.<# E.val tutId E.<&> (submissionUser E.^. SubmissionUserUser) E.<&> E.nothing + return $ TutorialParticipant E.<# E.val tutId E.<&> (submissionUser E.^. SubmissionUserUser) E.<&> E.nothing E.<&> E.nothing E.<&> E.nothing E.<&> E.nothing ) (\result -> do let countResult = Map.map Set.size result diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 078a928ad..0b271c547 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -51,6 +51,7 @@ import Text.Blaze.TestInstances () import qualified Data.Text.Lazy as LT import Text.Blaze.Html.Renderer.Text (renderHtml) +import Text.Shakespeare.I18N (renderMessage) import qualified Data.SemVer as SemVer import qualified Data.SemVer.Constraint as SemVer (Constraint) @@ -417,6 +418,12 @@ instance Arbitrary LmsDay where deriving newtype instance Arbitrary LmsIdent +instance Arbitrary UserDrivingPermit where + arbitrary = genericArbitrary + +instance Arbitrary UserEyeExam where + arbitrary = genericArbitrary + spec :: Spec spec = do parallel $ do @@ -538,6 +545,10 @@ spec = do [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, csvFieldLaws ] lawsCheckHspec (Proxy @LmsDay) [ eqLaws, ordLaws, showLaws, showReadLaws, csvFieldLaws ] + lawsCheckHspec (Proxy @UserDrivingPermit) + [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, persistFieldLaws ] + lawsCheckHspec (Proxy @UserEyeExam) + [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, persistFieldLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ @@ -642,6 +653,20 @@ spec = do showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 0, byDeficit = 0 } CorrectorNormal `shouldBe` "-D" showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]" showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}" + describe "UserDrivingPermit" $ do + it "encodes to DB as shown to user" . property $ + \(v :: UserDrivingPermit) -> + let tv = tshow v + in cmpJsonStringCI v tv && tv == renderMessage (error "renderMessage: foundation inspected") [] v + describe "UserEyeExam" $ do + it "encodes to DB as shown to user" . property $ + \(v :: UserEyeExam) -> + let tv = tshow v + in cmpJsonStringCI v tv && tv == renderMessage (error "renderMessage: foundation inspected") [] v + where + cmpJsonStringCI :: Aeson.ToJSON a => a -> Text -> Bool + cmpJsonStringCI (Aeson.toJSON -> Aeson.String s) t = CI.mk s == CI.mk t + cmpJsonStringCI _ _ = False termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs index b3b8aaea6..e54aaea84 100644 --- a/test/Utils/TypesSpec.hs +++ b/test/Utils/TypesSpec.hs @@ -10,27 +10,27 @@ import Utils import qualified Data.Aeson as Aeson -instance Arbitrary SloppyBool where +instance Arbitrary SloppyBool where arbitrary = SloppyBool <$> arbitrary shrink (SloppyBool x) = SloppyBool <$> shrink x -instance Arbitrary AvsInternalPersonalNo where +instance Arbitrary AvsInternalPersonalNo where arbitrary = mkAvsInternalPersonalNo <$> arbitrary shrink (AvsInternalPersonalNo x) = mkAvsInternalPersonalNo <$> shrink x -instance Arbitrary AvsPersonId where +instance Arbitrary AvsPersonId where arbitrary = AvsPersonId <$> arbitrary shrink (AvsPersonId x) = AvsPersonId <$> shrink x -instance Arbitrary AvsCardNo where +instance Arbitrary AvsCardNo where arbitrary = AvsCardNo . normalizeAvsCardNo <$> arbitrary shrink (AvsCardNo x) = AvsCardNo . normalizeAvsCardNo <$> shrink x -instance Arbitrary AvsLicence where +instance Arbitrary AvsLicence where arbitrary = genericArbitrary shrink = genericShrink -instance Arbitrary AvsObjPersonId where +instance Arbitrary AvsObjPersonId where arbitrary = genericArbitrary shrink = genericShrink @@ -39,7 +39,7 @@ instance Arbitrary AvsDataCardColor where shrink = genericShrink instance Arbitrary AvsDataPersonCard where - arbitrary = canonical <$> genericArbitrary + arbitrary = canonical <$> genericArbitrary shrink = fmap canonical <$> genericShrink instance Arbitrary AvsStatusPerson where @@ -63,7 +63,7 @@ instance Arbitrary AvsResponsePerson where shrink = genericShrink instance Arbitrary AvsResponseStatus where - arbitrary = genericArbitrary + arbitrary = resize 5 genericArbitrary shrink = genericShrink instance Arbitrary AvsResponseSetLicences where @@ -125,7 +125,7 @@ spec = do lawsCheckHspec (Proxy @AvsQuerySetLicences) [ eqLaws, showLaws, jsonLaws] - describe "AvsLicence" $ do + describe "AvsLicence" $ do it "ordering is consistent with its PersistField instance" . property $ -- this assumption is used in Handler.Utils.Avs.synchAvsLicences \a (b :: AvsLicence) -> compare a b == compare (toPersistValue a) (toPersistValue b) it "assigns AvsLicence fixed SQL values" . example $ do -- ensure that DB encoding does not change unnoticed @@ -135,8 +135,8 @@ spec = do Aeson.toJSON AvsLicenceVorfeld `shouldBe` Aeson.Number 1 Aeson.toJSON AvsLicenceRollfeld `shouldBe` Aeson.Number 2 - describe "Ord AvsPersonLicence" $ do - it "proritises avsLicenceRampLicence" . property $ + describe "Ord AvsPersonLicence" $ do + it "proritises avsLicenceRampLicence" . property $ \p0 p1@AvsPersonLicence{avsLicenceRampLicence=v1} -> let p2@AvsPersonLicence{avsLicenceRampLicence=v2} = p0 in (v1 /= v2) ==> compare p1 p2 == compare v1 v2 From 8317f682d8ffd0c42434c6def19b881bea9bde0c Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 23 Oct 2024 16:12:18 +0200 Subject: [PATCH 052/187] chore(tutorial): (WIP) towards #90 write form columns --- src/Handler/School/DayTasks.hs | 58 ++++++++++++++++++++++++++++++---- src/Model/Types/User.hs | 3 +- test/Model/TypesSpec.hs | 4 +-- 3 files changed, 56 insertions(+), 9 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index c523eb3c3..ddc3fbc04 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -20,7 +20,7 @@ import Handler.Utils.Occurrences import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Aeson as Aeson --- import qualified Data.Text as Text +import qualified Data.Text as Text -- import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) @@ -227,6 +227,51 @@ instance HasUser DailyTableData where -- see colRatedField' for an example of formCell usage +drivingPermitField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserDrivingPermit +drivingPermitField = selectField' Nothing optionsFinite + +-- eyeExamField :: Field (HandlerFor UniWorX) UserEyeExam +-- eyeExamField = selectField optionsFinite + +-- This does not type: +-- colParticipantPermitField :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +-- colParticipantPermitField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table +-- (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result +-- (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique -> +-- over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") $ Just x +-- ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + +-- colEyeExamField :: TODO + +colParticipantNoteField :: ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParticipantNoteField l = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table + (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result + (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique -> + over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> + mopt textareaField (fsUniq mkUnique "note-participant") (Just $ Textarea <$> note) + ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + +colAttendanceField :: Text -> ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colAttendanceField dday l = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table + (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result + (\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique -> + over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance + ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + +colAttendnaceNoteField :: Text -> ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colAttendnaceNoteField dday l = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table + (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result + (\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique -> + over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> + mopt textareaField (fsUniq mkUnique "note-attendance") (Textarea <<$>> note) + ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + +colParkingField :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParkingField l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table + (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result + (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> + over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking + ) -- Given the row data and a callback to make an input name suitably unique generate the MForm mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do @@ -273,12 +318,13 @@ mkDailyTable isAdmin ssh nd = do , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn - , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> maybeCell x $ textCell . tshow - , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> maybeCell x $ textCell . tshow - , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> maybeCell x textCell - , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> maybeCell x tickmarkCell - , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> maybeCell x textCell + , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell + , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell + , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell + , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell + , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell + -- , colParkingField id ] dbtSorting = Map.fromList [ sortUserNameLink queryUser diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs index b7fec9225..0abcd42af 100644 --- a/src/Model/Types/User.hs +++ b/src/Model/Types/User.hs @@ -45,7 +45,7 @@ deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } ''UserDrivingPermit derivePersistFieldJSON ''UserDrivingPermit - +nullaryPathPiece ''UserDrivingPermit $ camelToPathPiece' 3 data UserEyeExam = UserEyeExamSX | UserEyeExamS01 @@ -62,3 +62,4 @@ deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } ''UserEyeExam derivePersistFieldJSON ''UserEyeExam +nullaryPathPiece ''UserEyeExam $ camelToPathPiece' 3 diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 0b271c547..4939b4f2f 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -546,9 +546,9 @@ spec = do lawsCheckHspec (Proxy @LmsDay) [ eqLaws, ordLaws, showLaws, showReadLaws, csvFieldLaws ] lawsCheckHspec (Proxy @UserDrivingPermit) - [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, persistFieldLaws ] + [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @UserEyeExam) - [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, persistFieldLaws ] + [ eqLaws, ordLaws, showLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, persistFieldLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ From 7e09636a2ba2ecc137bcca2e12b3ad82317f7c2e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 28 Oct 2024 16:11:45 +0100 Subject: [PATCH 053/187] chore(day): add missing form columns --- src/Handler/School/DayTasks.hs | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index ddc3fbc04..a48330c1e 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -230,18 +230,22 @@ instance HasUser DailyTableData where drivingPermitField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserDrivingPermit drivingPermitField = selectField' Nothing optionsFinite --- eyeExamField :: Field (HandlerFor UniWorX) UserEyeExam --- eyeExamField = selectField optionsFinite +eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserEyeExam +eyeExamField = selectField' Nothing optionsFinite --- This does not type: --- colParticipantPermitField :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) --- colParticipantPermitField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table --- (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result --- (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique -> --- over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") $ Just x --- ) -- Given the row data and a callback to make an input name suitably unique generate the MForm +colParticipantPermitField :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParticipantPermitField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table + (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result + (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique -> + over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") (Just x) + ) -- Given the row data and a callback to make an input name suitably unique generate the MForm --- colEyeExamField :: TODO +colParticipantEyeExamField :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParticipantEyeExamField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table + (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result + (\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique -> + over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam") (Just x) + ) -- Given the row data and a callback to make an input name suitably unique generate the MForm colParticipantNoteField :: ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) colParticipantNoteField l = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table @@ -324,7 +328,7 @@ mkDailyTable isAdmin ssh nd = do , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell - -- , colParkingField id + -- , colParkingField id -- TODO ] dbtSorting = Map.fromList [ sortUserNameLink queryUser From fcf1b6d9d82bc1a75cc03599987a4a867225d0f4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 28 Oct 2024 17:44:17 +0100 Subject: [PATCH 054/187] fix(icons): add missing icons --- assets/icons-src/fontawesome.json | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/assets/icons-src/fontawesome.json b/assets/icons-src/fontawesome.json index 32bd6f55a..cdd83ddb0 100644 --- a/assets/icons-src/fontawesome.json +++ b/assets/icons-src/fontawesome.json @@ -82,6 +82,7 @@ "at": "at", "supervisor": "person", "supervisor-foreign": "person-rays", +"superior": "user-tie", "waiting-for-user": "user-gear", "expired": "hourglass-end", "locked": "lock", @@ -92,6 +93,9 @@ "edit": "pen-to-square", "user-edit": "user-pen", "loading": "spinner", -"placeholder": "notdef" +"placeholder": "notdef", +"reroute": "diamond-turn-right", +"top": "award", +"wildcard": "asterisk" } From 5d46479a3355ba6f501a9ef558fb4313c523eefb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 28 Oct 2024 17:48:41 +0100 Subject: [PATCH 055/187] chore(icons): add instructions on how to add icons --- src/Utils/Icon.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index c6a50bd81..7cf3d4bca 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -29,6 +29,13 @@ type WidgetSiteless = forall site. WidgetFor site () -- We collect all used icons here for an overview. -- For consistency, some conditional icons are also provided, having suffix True/False +{- How to add icons: + - edit utils/rename-fa.json by adding "our-name": "fa-name" + - make sure to only use fontawesome v6.6.0 free icons + - delete directory node_modules +-} + + --------------------------------------------------------------------------- -- IMPORTANT: -- All icons must be manually registered within the following files: From e1dca7d6b096dfd2207d51d48d4380881f275e22 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 29 Oct 2024 13:38:23 +0100 Subject: [PATCH 056/187] chore(day): make form columns compile eventually --- src/Foundation/Type.hs | 4 +- src/Handler/School/DayTasks.hs | 157 ++++++++++++++++++++------------- 2 files changed, 97 insertions(+), 64 deletions(-) diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 7f6814ea7..d254a2826 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -105,8 +105,8 @@ instance HasCookieSettings RegisteredCookie UniWorX where instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings) - -type DB = YesodDB UniWorX +type DB = YesodDB UniWorX + -- ~ ReaderT SqlBackend (HandlerFor UniWorX) type DBRead = ReaderT SqlReadBackend (HandlerFor UniWorX) type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ()) type MsgRenderer = MsgRendererS UniWorX -- see Utils diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index a48330c1e..de4680891 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -34,16 +34,16 @@ import Database.Esqueleto.Utils.TH -data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +-- data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing +-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -instance Universe DailyTableAction -instance Finite DailyTableAction -nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2 -embedRenderMessage ''UniWorX ''DailyTableAction id +-- instance Universe DailyTableAction +-- instance Finite DailyTableAction +-- nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2 +-- embedRenderMessage ''UniWorX ''DailyTableAction id -data DailyTableActionData = DailyActDummyData - deriving (Eq, Ord, Read, Show, Generic) +-- data DailyTableActionData = DailyActDummyData +-- deriving (Eq, Ord, Read, Show, Generic) -- | partial JSON object to be used for filtering with "@>" -- ensure that a GIN index for the jsonb column is created in Model.Migration.Definitions @@ -153,6 +153,7 @@ type DailyTableOutput = E.SqlQuery , E.SqlExpr (E.Value (Maybe CompanyId)) , E.SqlExpr (E.Value (Maybe [QualificationId])) ) + type DailyTableData = DBRow ( Entity Course , Entity Tutorial @@ -165,6 +166,17 @@ type DailyTableData = DBRow , E.Value (Maybe [QualificationId]) ) +data DailyFormData = DailyFormData + { dailyFormDrivingPermit :: Maybe UserDrivingPermit + , dailyFormEyeExam :: Maybe UserEyeExam + , dailyFormParticipantNote :: Maybe Text + , dailyFormAttendance :: Bool + , dailyFormAttendanceNote :: Maybe Text + , dailyFormParkingToken :: Bool + } deriving (Eq, Show) + +makeLenses_ ''DailyFormData + -- force declarations before this point to avoid staging restrictions $(return []) @@ -233,51 +245,60 @@ drivingPermitField = selectField' Nothing optionsFinite eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserEyeExam eyeExamField = selectField' Nothing optionsFinite -colParticipantPermitField :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantPermitField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table +colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit + +colParticipantPermitField' :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") (Just x) ) -- Given the row data and a callback to make an input name suitably unique generate the MForm -colParticipantEyeExamField :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantEyeExamField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table - (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result +colParticipantEyeExamField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colParticipantEyeExamField = colParticipantEyeExamField' _dailyFormEyeExam + +colParticipantEyeExamField' :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParticipantEyeExamField' l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id + (views (resultParticipant . _entityKey) return) (\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam") (Just x) - ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + ) -colParticipantNoteField :: ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantNoteField l = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table - (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result +colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colParticipantNoteField = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id + (views (resultParticipant . _entityKey) return) (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique -> - over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> + over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "note-participant") (Just $ Textarea <$> note) - ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + ) -colAttendanceField :: Text -> ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colAttendanceField dday l = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table - (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result +colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id + (views (resultParticipant . _entityKey) return) (\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique -> - over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance - ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + over (_1.mapped) (_dailyFormAttendance .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance + ) -colAttendnaceNoteField :: Text -> ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colAttendnaceNoteField dday l = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table - (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result +colAttendanceNoteField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colAttendanceNoteField dday = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id + (views (resultParticipant . _entityKey) return) (\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique -> - over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> + over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "note-attendance") (Textarea <<$>> note) - ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + ) -colParkingField :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParkingField l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table - (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result +colParkingField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colParkingField = colParkingField' _dailyFormParkingToken + +colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id + (views (resultParticipant . _entityKey) return) (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking - ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + ) -mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) +mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Widget) mkDailyTable isAdmin ssh nd = do tutLessons <- getDayTutorials' ssh (nd,nd) dday <- formatTime SelFormatDate nd @@ -303,7 +324,7 @@ mkDailyTable isAdmin ssh nd = do return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications) dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId) dbtProj = dbtProjId - dbtColonnade = mconcat + dbtColonnade = formColonnade $ mconcat [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row -> @@ -328,7 +349,12 @@ mkDailyTable isAdmin ssh nd = do , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell - -- , colParkingField id -- TODO + , colParticipantPermitField + , colParticipantEyeExamField + , colParticipantNoteField + , colAttendanceField dday + , colAttendanceNoteField dday + , colParkingField ] dbtSorting = Map.fromList [ sortUserNameLink queryUser @@ -365,33 +391,40 @@ mkDailyTable isAdmin ssh nd = do dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] - dbtParams = DBParamsForm - { dbParamsFormMethod = POST - , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute - , dbParamsFormAttrs = [] - , dbParamsFormSubmit = FormNoSubmit - , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty) - -- , dbParamsFormSubmit = FormSubmit - -- , dbParamsFormAdditional - -- = let acts :: Map MCTableAction (AForm Handler MCTableActionData) - -- acts = mconcat - -- [ singletonMap MCActDummy $ pure MCActDummyData - -- ] - -- in renderAForm FormStandard - -- $ (, mempty) . First . Just - -- <$> multiActionA acts (fslI MsgTableAction) Nothing - , dbParamsFormEvaluate = liftHandler . runFormPost - , dbParamsFormResult = id - , dbParamsFormIdent = def - } - postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialId Bool DailyTableData) - -> FormResult ( DailyTableActionData, Set TutorialId) - postprocess inp = do - (First (Just act), jobMap) <- inp - let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap - return (act, jobSet) + dbtParams = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd } + -- dbtParams = DBParamsForm + -- { dbParamsFormMethod = POST + -- , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute + -- , dbParamsFormAttrs = [] + -- , dbParamsFormSubmit = FormSubmit + -- , dbParamsFormAdditional = \frag -> do + -- let acts :: Map DailyTableAction (AForm Handler DailyTableActionData) + -- acts = mconcat + -- [ singletonMap DailyActDummy $ pure DailyActDummyData + -- ] + -- (actionRes, action) <- multiActionM acts "" Nothing mempty + -- return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) + -- -- , dbParamsFormAdditional + -- -- = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData) + -- -- acts = mconcat + -- -- [ singletonMap DailyActDummy $ pure DailyActDummyData + -- -- ] + -- -- in renderAForm FormStandard + -- -- $ (, mempty) . First . Just + -- -- <$> multiActionA acts (fslI MsgTableAction) Nothing + -- , dbParamsFormEvaluate = liftHandler . runFormPost + -- , dbParamsFormResult = _1 + -- , dbParamsFormIdent = def + -- } + -- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData) + -- -> FormResult ( DailyTableActionData, Set TutorialId) + -- postprocess inp = do + -- (First (Just act), jobMap) <- inp + -- let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap + -- return (act, jobSet) psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"] - over _1 postprocess <$> dbTable psValidator DBTable{..} + -- over _1 postprocess <$> dbTable psValidator DBTable{..} + dbTable psValidator DBTable{..} getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html From cd76bdd4e769b91458c62e0692b5defee8487f21 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 29 Oct 2024 18:16:29 +0100 Subject: [PATCH 057/187] chore(day): complete form columns for daily view (untested) unfortunately `make start` does not enter DEVELOPMENT mode currently, so this is not yet testeted. --- .../courses/tutorial/de-de-formal.msg | 3 +- .../categories/courses/tutorial/en-eu.msg | 3 +- src/Handler/School/DayTasks.hs | 65 +++++++++++++++---- src/Utils/DB.hs | 7 ++ 4 files changed, 65 insertions(+), 13 deletions(-) diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 4311bf005..5969b085e 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -55,4 +55,5 @@ TutorialDrivingPermit: Führerschein TutorialEyeExam: Sehtest TutorialNote: Kursnotiz TutorialDayAttendance day@Text: Anwesenheit am #{day} -TutorialDayNote day@Text: Anwesenheitsnotiz für #{day} \ No newline at end of file +TutorialDayNote day@Text: Anwesenheitsnotiz für #{day} +TutorialParticipantsDayEdits n@Int: #{tshow n} Kursteilnehmer-Tagesnotizen aktualisiert \ No newline at end of file diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 407bb1b88..b1e027eaa 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -56,4 +56,5 @@ TutorialDrivingPermit: Driving permit TutorialEyeExam: Eye exam TutorialNote: Course note TutorialDayAttendance day: Attendance #{day} -TutorialDayNote day: Attendance note #{day} \ No newline at end of file +TutorialDayNote day: Attendance note #{day} +TutorialParticipantsDayEdits n@Int: #{tshow n} course participant day notes updated \ No newline at end of file diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index de4680891..bcc7475d5 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -245,6 +245,13 @@ drivingPermitField = selectField' Nothing optionsFinite eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserEyeExam eyeExamField = selectField' Nothing optionsFinite +mkDailyFormColumn :: (RenderMessage UniWorX msg) => Text -> msg -> Lens' DailyTableData a -> ASetter' DailyFormData a -> Field _ a -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +mkDailyFormColumn k msg lg ls f = sortable (Just $ SortingKey $ stripCI k) (i18nCell msg) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table + (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result + (\(view lg -> x) mkUnique -> + over (_1.mapped) (ls .~) . over _2 fvWidget <$> mreq f (fsUniq mkUnique k) (Just x) + ) -- Given the row data and a callback to make an input name suitably unique generate the MForm + colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit @@ -259,18 +266,18 @@ colParticipantEyeExamField :: Colonnade Sortable DailyTableData (DBCell _ (FormR colParticipantEyeExamField = colParticipantEyeExamField' _dailyFormEyeExam colParticipantEyeExamField' :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantEyeExamField' l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id +colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialNote) $ formCell id (views (resultParticipant . _entityKey) return) (\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam") (Just x) ) colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) -colParticipantNoteField = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id +colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique -> over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> - mopt textareaField (fsUniq mkUnique "note-participant") (Just $ Textarea <$> note) + mopt textareaField (fsUniq mkUnique "note-tutorial") (Just $ Textarea <$> note) ) colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) @@ -281,7 +288,7 @@ colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDa ) colAttendanceNoteField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) -colAttendanceNoteField dday = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id +colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique -> over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> @@ -343,18 +350,19 @@ mkDailyTable isAdmin ssh nd = do , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn - , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell - , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell - , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell - , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell - , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell - , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell , colParticipantPermitField , colParticipantEyeExamField , colParticipantNoteField , colAttendanceField dday , colAttendanceNoteField dday , colParkingField + -- TODO: DEBUG ONLY + , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell + , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell + , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell + , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell + , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell + , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell ] dbtSorting = Map.fromList [ sortUserNameLink queryUser @@ -432,7 +440,42 @@ getSchoolDayR = postSchoolDayR postSchoolDayR ssh nd = do isAdmin <- hasReadAccessTo AdminR dday <- formatTime SelFormatDate nd - (_,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd + let unFormResult = getDBFormResult $ \row -> let tpt = row ^. resultParticipant . _entityVal + in DailyFormData + { dailyFormDrivingPermit = tpt ^. _tutorialParticipantDrivingPermit + , dailyFormEyeExam = tpt ^. _tutorialParticipantEyeExam + , dailyFormParticipantNote = tpt ^. _tutorialParticipantNote + , dailyFormAttendance = row ^? resultParticipantDay ._tutorialParticipantDayAttendance & fromMaybe False + , dailyFormAttendanceNote = row ^? resultParticipantDay ._tutorialParticipantDayNote . _Just + , dailyFormParkingToken = row ^? resultUserDay . _userDayParkingToken & fromMaybe False + } + (fmap unFormResult -> tableRes,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd + formResult tableRes $ \resMap -> runDB $ do + forM_ (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do + TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated + when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit + || tutorialParticipantEyeExam /= dailyFormEyeExam + || tutorialParticipantNote /= dailyFormParticipantNote) $ + update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit + , TutorialParticipantEyeExam =. dailyFormEyeExam + , TutorialParticipantNote =. dailyFormParticipantNote + ] + let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd + if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote) + then deleteBy tpdUq + else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote) + [ TutorialParticipantDayAttendance =. dailyFormAttendance + , TutorialParticipantDayNote =. dailyFormAttendanceNote + ] + let udUq = UniqueUserDay tutorialParticipantUser nd + updateUserDay = if dailyFormParkingToken + then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued + else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False + updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken] + -- TODO: audit log? + addMessageI Success $ MsgTutorialParticipantsDayEdits $ Map.size resMap + redirect $ SchoolR ssh $ SchoolDayR nd + siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do setTitleI (MsgMenuSchoolDay ssh dday) [whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)} diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 7cf9dc8a9..24b71dec3 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -202,6 +202,13 @@ upsertBySafe uniq newr upd = maybeM (insertUnique newr) do_upd (getBy uniq) delete oid insertUnique $ upd oldr +upsertBy_ :: ( MonadIO m + , PersistEntity record + , PersistUniqueWrite backend + , PersistEntityBackend record ~ BaseBackend backend + ) + => Unique record -> record -> [Update record] -> ReaderT backend m () +upsertBy_ = ((void .) .) . upsertBy checkUniqueKeys :: ( MonadIO m , PersistUniqueRead backend From d2f69dc02301e443042dfd54ecd27fbcc0c66f38 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 30 Oct 2024 17:18:11 +0100 Subject: [PATCH 058/187] fix(doc): minor haddock fixes --- src/Utils.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Utils.hs b/src/Utils.hs index d8545175e..bd6f8171f 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -955,20 +955,23 @@ deepAlt altFst _ = altFst maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty = flip foldMap --- The more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a` +-- | A more general variant of `find :: Foldable t => (a -> Bool) -> t a -> Maybe a` filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a filterMaybe c r@(Just x) | c x = r filterMaybe _ _ = Nothing --- | also referred to as whenJust and forM_ --- also see `foldMapM` if a Monoid value is to be returned --- also see `forMM_` if the maybe is produced by a monadic action +-- | also referred to as `whenJust` and `forM_`; +-- also see `foldMapM`, if a Monoid value is to be returned; +-- also see `forMM_`, if the maybe is produced by a monadic action whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () --- ifNothingM m d a = maybe (return d) a m -ifNothingM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM +-- | -- Often a more convenient argument order as compared to the not quite identical `maybeM` +-- @ +-- ifNothingM m d a = maybe (return d) a m +-- @ +ifNothingM :: Monad m => Maybe a -> b -> (a -> m b) -> m b ifNothingM Nothing dft _ = return dft ifNothingM (Just x) _ act = act x From 6f1ad811f73aaf5f02a11ac92889e1f03f964df2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 4 Nov 2024 18:20:43 +0100 Subject: [PATCH 059/187] chore(firm): add action to add non-avs firm associates --- .../uniworx/categories/firm/de-de-formal.msg | 5 +- messages/uniworx/categories/firm/en-eu.msg | 5 +- src/Handler/Firm.hs | 83 +++++++++++++++---- src/Utils/DB.hs | 12 +++ 4 files changed, 86 insertions(+), 19 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 8f27c24c4..d526dc8c4 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -21,8 +21,11 @@ FirmActResetSupersKeepAll: Alle behalten FirmActResetSupersRemoveAps: Nur Standardansprechpartner entfernen FirmActResetSupersRemoveAll: Alle entfernen FirmActAddSupervisors: Ansprechpartner hinzufügen -FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden +FirmActAddAssociates: Firmenangehörige hinzufügen +FirmActAddSupersEmpty: Es konnten keine neuen Ansprechpartner hinzugefügt werden! FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. +FirmActAddAssocsEmpty: Es konnten keine neuen Firmenangehörige hinzugefügt werden! +FirmActAddAssocs n@Int64: #{n} Firmenangehörige hinzugefügt. RemoveSupervisors ndef@Int64: #{ndef} Standardansprechpartner entfernt. FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern FirmActChangeContactFirm: Kontaktinformationen der Firma ändern diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index fe4dbc045..991164701 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -21,8 +21,11 @@ FirmActResetSupersKeepAll: Keep all FirmActResetSupersRemoveAps: Remove default supervisors only FirmActResetSupersRemoveAll: Remove all FirmActAddSupervisors: Add supervisors -FirmActAddSupersEmpty: No supervisors added +FirmActAddAssociates: Associate users with company +FirmActAddSupersEmpty: No new supervisors added! FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. +FirmActAddAssocsEmpty: No new company associated users added! +FirmActAddAssocs n@Int64: #{pluralENsN n "company associated user"} added. RemoveSupervisors ndef: #{ndef} default supervisors removed. FirmActChangeContactUser: Change contact data for all company associates FirmActChangeContactFirm: Change company contact data diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index fa5e52d8f..ad44d1257 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -54,6 +54,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU data FirmAction = FirmActNotify | FirmActResetSupervision | FirmActAddSupervisors + | FirmActAddAssociates | FirmActChangeContactFirm | FirmActChangeContactUser deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -64,24 +65,31 @@ embedRenderMessage ''UniWorX ''FirmAction id data FirmActionData = FirmActNotifyData | FirmActResetSupervisionData - { firmActResetKeepOldSupers :: Maybe Bool - , firmActResetMutualSupervision :: Maybe Bool + { firmActResetKeepOldSupers :: Maybe Bool + , firmActResetMutualSupervision :: Maybe Bool } | FirmActAddSupervisorsData - { firmActAddSupervisorIds :: Set Text - , firmActAddSupervisorReroute :: Bool - , firmActAddSupervisorPostal :: Maybe Bool - , firmActAddSupervisorReason :: Maybe Text + { firmActAddUserIds :: Set Text + , firmActAddSupervisorReroute :: Bool + , firmActAddSupervisorPostal :: Maybe Bool + , firmActAddUserUseCompanyAddress :: Bool + , firmActAddSupervisorReason :: Maybe Text + } + | FirmActAddAssociatesData + { firmActAddUserIds :: Set Text + , firmActAddAssociatePriority :: Int + , firmActAddUserUseCompanyAddress :: Bool + , firmActAddAssociateReason :: Maybe Text } | FirmActChangeContactFirmData - { firmActCCFPostalAddr :: Maybe StoredMarkup - , firmActCCFEmail :: Maybe UserEmail - , firmActCCFPostalPref :: Maybe Bool + { firmActCCFPostalAddr :: Maybe StoredMarkup + , firmActCCFEmail :: Maybe UserEmail + , firmActCCFPostalPref :: Maybe Bool } | FirmActChangeContactUserData - { firmActCCUPostalAddr :: Maybe StoredMarkup - , firmActCCUUseCompanyPostal :: Maybe Bool - , firmActCCUPostalPref :: Maybe Bool + { firmActCCUPostalAddr :: Maybe StoredMarkup + , firmActCCUUseCompanyPostal :: Maybe Bool + , firmActCCUPostalPref :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) @@ -93,11 +101,18 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <$> aopt boolField' (fslI MsgFirmActResetSuperKeep) (Just $ Just False) <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) mkAct _ FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData - <$> areq (textField & cfAnySeparatedSet) (fslI MsgFirmSuperDefault & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <$> areq (textField & cfAnySeparatedSet) (fslI MsgFirmSuperDefault & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True) <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <*> areq checkBoxField (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) (Just True) <*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons) (fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip) Nothing + mkAct _ FirmActAddAssociates = singletonMap FirmActAddAssociates $ FirmActAddAssociatesData + <$> areq (textField & cfAnySeparatedSet) (fslI MsgFirmAssociates & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> areq intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) (Just 0) + <*> areq checkBoxField (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) (Just True) + <*> aopt (textField & cfStrip & addDatalist ucdefAssocReasons) + (fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip) Nothing mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing @@ -112,7 +127,15 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) ucdefSuperReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $ fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do usrc <- E.from $ E.table @UserCompany - E.where_ $ E.isJust $ usrc E.^. UserCompanyReason + E.where_ $ E.isJust (usrc E.^. UserCompanyReason) + E.&&. usrc E.^. UserCompanySupervisor + return $ usrc E.^. UserCompanyReason + ucdefAssocReasons :: HandlerFor UniWorX (OptionList Text) + ucdefAssocReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $ + fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do + usrc <- E.from $ E.table @UserCompany + E.where_ $ E.isJust (usrc E.^. UserCompanyReason) + E.&&. E.not__ (usrc E.^. UserCompanySupervisor) return $ usrc E.^. UserCompanyReason @@ -158,7 +181,7 @@ firmActionHandler route isAdmin = flip formResult faHandler reloadKeepGetParams route -- reload to reflect changes faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do - avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddUserIds let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers usersFound = mapMaybe snd usersFound' unless (null usersNotFound) $ @@ -175,12 +198,38 @@ firmActionHandler route isAdmin = flip formResult faHandler runDB $ do -- putMany [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] -- putMany always overwrites existing records, which would destroy priority and useCompanyAddress here -- upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [copyField UserCompanySupervisor, copyField UserCompanySupervisorReroute] [] [] -- overwrite Supervisor and SupervisorReroute, keep priority and useCompanyAddress - upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False firmActAddSupervisorReason| uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute, UserCompanyReason =. firmActAddSupervisorReason] [] -- identical to previous line, but perhaps more clear? + upsertManyWhere + [UserCompany uid cid True firmActAddSupervisorReroute 0 firmActAddUserUseCompanyAddress firmActAddSupervisorReason | uid <- usersFound] + [] + [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute, UserCompanyReason =. firmActAddSupervisorReason] + [] -- identical to previous line, but perhaps more clear? whenIsJust firmActAddSupervisorPostal $ \prefPostal -> updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal redirect route + faHandler (FirmActAddAssociatesData{..}, Set.toList -> [cid]) = do + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddUserIds + let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers + usersFound = mapMaybe snd usersFound' + unless (null usersNotFound) $ + let msgContent = [whamlet| + $newline never +
            + $forall (usr,_) <- usersNotFound +
          • #{usr} + |] + in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + when (null usersFound) $ do + addMessageI Warning MsgFirmActAddAssocsEmpty + reloadKeepGetParams route + runDB $ do + oks0 <- mapM insertUnique_ [UserCompany uid cid False False firmActAddAssociatePriority firmActAddUserUseCompanyAddress firmActAddAssociateReason | uid <- usersFound] + let oks = length $ catMaybes oks0 + allok = bool Warning Success $ oks == length usersFound + addMessageI allok $ MsgFirmActAddAssocs (fromIntegral oks) + redirect route + faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) = let changes = catMaybes [ (CompanyPostAddress =.) . Just <$> canonical firmActCCFPostalAddr @@ -1139,7 +1188,7 @@ postFirmUsersR fsh = do addMessageI allok $ someMessages [MsgFirmUserActRemoveResult nrUc, MsgFirmRemoveSupervision nrSuper nrSubs] reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser] + formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddAssociates, FirmActChangeContactFirm, FirmActChangeContactUser] siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 24b71dec3..05be82c96 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -222,6 +222,18 @@ checkUniqueKeys (x:xs) = do Nothing -> checkUniqueKeys xs Just _ -> return (Just x) +-- Backport from version persistent-2.14.6.3 +insertUnique_ :: ( MonadIO m + , PersistEntity record + , PersistUniqueWrite backend + , PersistEntityBackend record ~ BaseBackend backend + ) + => record -> ReaderT backend m (Maybe ()) +insertUnique_ datum = do + conflict <- checkUnique datum + case conflict of + Nothing -> Just <$> insert_ datum + Just _ -> return Nothing put :: ( MonadIO m , PersistUniqueWrite backend From 0a29540089eee510c7126142573a389d955fd6e0 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 5 Nov 2024 10:53:04 +0100 Subject: [PATCH 060/187] fix(doc): Update outdated GitLab references to DevOps work items --- src/Database/Esqueleto/Utils.hs | 3 ++- src/Handler/Course/Edit.hs | 4 ++-- src/Handler/Health/Interface.hs | 2 +- src/Utils.hs | 7 ++++--- 4 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 152d506ae..9c09b41f9 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -280,7 +280,8 @@ subSelectOr q = parens . E.subSelectUnsafe $ flip (E.unsafeSqlAggregateFunction parens :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) parens = E.unsafeSqlFunction "" --- | Workaround for Esqueleto-Bug not placing parenthesis after NOT, see #155 +-- | Workaround for Esqueleto-Bug not placing parenthesis after NOT. +-- This leads to erroneous filters. For examples, see DevOps #1970 not__ :: E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool) not__ = E.not_ . parens diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 1e06c919b..17fe34a67 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -70,7 +70,7 @@ courseToForm (Entity cid Course{..}) lecs lecInvites qualis = CourseForm , cfDeRegUntil = courseDeregisterUntil , cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs] ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ] - -- TODO: Filterung nach aktueller Schule, da ansonsten ein Sicherheitleck droht! Siehe #150 + -- TODO: Filterung nach aktueller Schule, da ansonsten ein Sicherheitleck droht! Siehe auch DevOps #1878 , cfQualis = [ (courseQualificationQualification, courseQualificationSortOrder) | CourseQualification{..} <- qualis, courseQualificationCourse == cid ] } @@ -471,7 +471,7 @@ upsertCourseQualifications uid cid qualis = do let newQualis = Map.fromList qualis oldQualis <- Map.fromList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder))) <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationQualification] - -- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications, see #150 + -- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications here! Also see DevOps #1878 okSchools <- Set.fromList . fmap (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool] {- Some debugging due to an error caused by using fromDistinctAscList with violated precondition: diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 58cfcbe4a..e19945f1b 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -150,7 +150,7 @@ mkInterfaceLogTable interfs@(reqIfs, banIfs) = do ] unless (null reqIfs) $ E.where_ $ matchUIH reqIfs unless (null banIfs) $ E.where_ $ matchUIHnot banIfs - -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155 + -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see DevOps #1970 -- unless (null banIfs) $ E.where_ $ E.not_ $ E.parens $ matchUIH banIfs -- WORKS OKAY -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F" -- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY diff --git a/src/Utils.hs b/src/Utils.hs index bd6f8171f..2b34d3575 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -967,12 +967,13 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () --- | -- Often a more convenient argument order as compared to the not quite identical `maybeM` +-- | Often a more convenient argument order as compared to the not quite identical `maybeM`. +-- -- @ -- ifNothingM m d a = maybe (return d) a m -- @ -ifNothingM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -ifNothingM Nothing dft _ = return dft +ifNothingM :: Applicative m => Maybe a -> b -> (a -> m b) -> m b +ifNothingM Nothing dft _ = pure dft ifNothingM (Just x) _ act = act x maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespeare: one $maybe instead of $with & $if From 162c44a44f08eb4803a80566d171417a92d839ed Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 11 Nov 2024 13:26:57 +0100 Subject: [PATCH 061/187] fix(msg): minor uni2wok to fradrive message change Primarly done to the the new build environment start-backend file watcher and see whether a restart enables the website --- messages/uniworx/utils/site_layout/de-de-formal.msg | 4 ++-- messages/uniworx/utils/site_layout/en-eu.msg | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/messages/uniworx/utils/site_layout/de-de-formal.msg b/messages/uniworx/utils/site_layout/de-de-formal.msg index 34681feea..55174f07c 100644 --- a/messages/uniworx/utils/site_layout/de-de-formal.msg +++ b/messages/uniworx/utils/site_layout/de-de-formal.msg @@ -12,8 +12,8 @@ NewsHeading: Aktuelles InfoHeading: Informationen LegalHeading: Rechtliche Informationen VersionHeading: Versionsgeschichte -SystemMessageHeading: Uni2work Statusmeldung -SystemMessageListHeading: Uni2work Statusmeldungen +SystemMessageHeading: FRADrive Statusmeldung +SystemMessageListHeading: FRADrive Statusmeldungen HeadingHelpRequest: Supportanfrage/Verbesserungsvorschlag ProfileHeading: Benutzereinstellungen ProfileDataHeading: Gespeicherte Benutzerdaten diff --git a/messages/uniworx/utils/site_layout/en-eu.msg b/messages/uniworx/utils/site_layout/en-eu.msg index d263f8217..2036666b9 100644 --- a/messages/uniworx/utils/site_layout/en-eu.msg +++ b/messages/uniworx/utils/site_layout/en-eu.msg @@ -12,8 +12,8 @@ NewsHeading: News InfoHeading: Information LegalHeading: Legal VersionHeading: Version history -SystemMessageHeading: Uni2work system message -SystemMessageListHeading: Uni2work system message +SystemMessageHeading: FRADrive system message +SystemMessageListHeading: FRADrive system messages HeadingHelpRequest: Support request/Suggestion ProfileHeading: Settings ProfileDataHeading: Personal information From d546e5da0fd4bf9589eed6cfc38775aadf7c089b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 20 Nov 2024 18:03:05 +0100 Subject: [PATCH 062/187] minor adjustments to routes and icons --- assets/icons-src/fontawesome.json | 2 +- routes | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/assets/icons-src/fontawesome.json b/assets/icons-src/fontawesome.json index cdd83ddb0..b1ec72cb1 100644 --- a/assets/icons-src/fontawesome.json +++ b/assets/icons-src/fontawesome.json @@ -76,7 +76,7 @@ "submission-no-users": "user-slash", "reset": "arrow-rotate-left", "blocked": "ban", -"certificate": "certificate", +"certificate": "person-circle-check", "print-center": "envelopes-bulk", "letter": "envelopes-bulk", "at": "at", diff --git a/routes b/routes index 64b459813..c6aa0743e 100644 --- a/routes +++ b/routes @@ -154,7 +154,7 @@ !/term/#TermId/#SchoolId TermSchoolCourseListR GET !free -/school SchoolListR GET !free +/school SchoolListR GET !/school/new SchoolNewR GET POST /school/#SchoolId SchoolR: /edit SchoolEditR GET POST From 9eb075836f6405071ec517ce035a69f799c3f3f6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 20 Nov 2024 18:03:36 +0100 Subject: [PATCH 063/187] fix(daily): form submit now works as intended --- .../courses/tutorial/de-de-formal.msg | 2 +- src/Handler/School/DayTasks.hs | 88 +++++++++++-------- 2 files changed, 52 insertions(+), 38 deletions(-) diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 5969b085e..f1064aa89 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -54,6 +54,6 @@ CommTutorial: Kursmitteilung TutorialDrivingPermit: Führerschein TutorialEyeExam: Sehtest TutorialNote: Kursnotiz -TutorialDayAttendance day@Text: Anwesenheit am #{day} +TutorialDayAttendance day@Text: Anwesenheit #{day} TutorialDayNote day@Text: Anwesenheitsnotiz für #{day} TutorialParticipantsDayEdits n@Int: #{tshow n} Kursteilnehmer-Tagesnotizen aktualisiert \ No newline at end of file diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index bcc7475d5..8a02f8048 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -240,10 +240,10 @@ instance HasUser DailyTableData where -- see colRatedField' for an example of formCell usage drivingPermitField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserDrivingPermit -drivingPermitField = selectField' Nothing optionsFinite +drivingPermitField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserEyeExam -eyeExamField = selectField' Nothing optionsFinite +eyeExamField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite mkDailyFormColumn :: (RenderMessage UniWorX msg) => Text -> msg -> Lens' DailyTableData a -> ASetter' DailyFormData a -> Field _ a -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) mkDailyFormColumn k msg lg ls f = sortable (Just $ SortingKey $ stripCI k) (i18nCell msg) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table @@ -256,7 +256,7 @@ colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormRe colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit colParticipantPermitField' :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table +colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") (Just x) @@ -266,18 +266,26 @@ colParticipantEyeExamField :: Colonnade Sortable DailyTableData (DBCell _ (FormR colParticipantEyeExamField = colParticipantEyeExamField' _dailyFormEyeExam colParticipantEyeExamField' :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialNote) $ formCell id +colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ formCell id (views (resultParticipant . _entityKey) return) (\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam") (Just x) ) +-- colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +-- colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id +-- (views (resultParticipant . _entityKey) return) +-- (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique -> +-- over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> +-- mopt textareaField (fsUniq mkUnique "note-tutorial") (Just $ Textarea <$> note) +-- ) + colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique -> - over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> - mopt textareaField (fsUniq mkUnique "note-tutorial") (Just $ Textarea <$> note) + over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$> + mopt textField (fsUniq mkUnique "note-tutorial") (Just note) ) colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) @@ -288,11 +296,15 @@ colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDa ) colAttendanceNoteField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) -colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id +colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:10%"), ("style","height:200px")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique -> over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> - mopt textareaField (fsUniq mkUnique "note-attendance") (Textarea <<$>> note) + mopt textareaField (fsUniq mkUnique "note-attendance" + -- & addAutosubmit -- submits while typing + & addAttr "cols" "7" + & addAttr "rows" "2" -- does not work if height is set via css (search "170px") + ) (Textarea <<$>> note) ) colParkingField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) @@ -356,13 +368,13 @@ mkDailyTable isAdmin ssh nd = do , colAttendanceField dday , colAttendanceNoteField dday , colParkingField - -- TODO: DEBUG ONLY - , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell - , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell - , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell - , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell - , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell - , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell + -- FOR DEBUGGING ONLY + -- , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell + -- , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell + -- , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell + -- , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell + -- , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell + -- , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell ] dbtSorting = Map.fromList [ sortUserNameLink queryUser @@ -450,28 +462,30 @@ postSchoolDayR ssh nd = do , dailyFormParkingToken = row ^? resultUserDay . _userDayParkingToken & fromMaybe False } (fmap unFormResult -> tableRes,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd - formResult tableRes $ \resMap -> runDB $ do - forM_ (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do - TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated - when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit - || tutorialParticipantEyeExam /= dailyFormEyeExam - || tutorialParticipantNote /= dailyFormParticipantNote) $ - update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit - , TutorialParticipantEyeExam =. dailyFormEyeExam - , TutorialParticipantNote =. dailyFormParticipantNote - ] - let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd - if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote) - then deleteBy tpdUq - else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote) - [ TutorialParticipantDayAttendance =. dailyFormAttendance - , TutorialParticipantDayNote =. dailyFormAttendanceNote - ] - let udUq = UniqueUserDay tutorialParticipantUser nd - updateUserDay = if dailyFormParkingToken - then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued - else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False - updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken] + formResult tableRes $ \resMap -> do + runDB $ do + forM_ (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do + -- $logDebugS "TableForm" (tshow dfd) + TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated + when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit + || tutorialParticipantEyeExam /= dailyFormEyeExam + || tutorialParticipantNote /= dailyFormParticipantNote) $ + update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit + , TutorialParticipantEyeExam =. dailyFormEyeExam + , TutorialParticipantNote =. dailyFormParticipantNote + ] + let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd + if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote) + then deleteBy tpdUq + else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote) + [ TutorialParticipantDayAttendance =. dailyFormAttendance + , TutorialParticipantDayNote =. dailyFormAttendanceNote + ] + let udUq = UniqueUserDay tutorialParticipantUser nd + updateUserDay = if dailyFormParkingToken + then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued + else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False + updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken] -- TODO: audit log? addMessageI Success $ MsgTutorialParticipantsDayEdits $ Map.size resMap redirect $ SchoolR ssh $ SchoolDayR nd From ede00deb868627446574c8f66ccf0d817c5e6a50 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Nov 2024 17:59:10 +0100 Subject: [PATCH 064/187] refactor(daily): user company discrepancies --- assets/icons-src/fontawesome.json | 3 ++- src/Handler/School/DayTasks.hs | 27 +++++++++++++++++++++++---- src/Utils/Icon.hs | 7 ++++--- 3 files changed, 29 insertions(+), 8 deletions(-) diff --git a/assets/icons-src/fontawesome.json b/assets/icons-src/fontawesome.json index b1ec72cb1..8323cda98 100644 --- a/assets/icons-src/fontawesome.json +++ b/assets/icons-src/fontawesome.json @@ -76,7 +76,7 @@ "submission-no-users": "user-slash", "reset": "arrow-rotate-left", "blocked": "ban", -"certificate": "person-circle-check", +"certificate": "car-side", "print-center": "envelopes-bulk", "letter": "envelopes-bulk", "at": "at", @@ -90,6 +90,7 @@ "trash": "trash", "reset-tries": "trash-can-arrow-up", "company": "building", +"company-warning": "building-circle-exclamation", "edit": "pen-to-square", "user-edit": "user-pen", "loading": "spinner", diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 8a02f8048..dd11b28ee 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -256,7 +256,7 @@ colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormRe colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit colParticipantPermitField' :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table +colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") (Just x) @@ -266,7 +266,7 @@ colParticipantEyeExamField :: Colonnade Sortable DailyTableData (DBCell _ (FormR colParticipantEyeExamField = colParticipantEyeExamField' _dailyFormEyeExam colParticipantEyeExamField' :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ formCell id +colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ (cellAttrs <>~ [("style","width:2%")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam") (Just x) @@ -357,8 +357,27 @@ mkDailyTable isAdmin ssh nd = do cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons -- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell - , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid - , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid + -- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid + -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid + , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row -> + let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany + primComp = row ^? resultCompanyId + bookLink = cellMaybe companyIdCell bookComp + result + | primComp /= bookComp + , Just (unCompanyKey -> csh) <- primComp + = bookLink + <> spacerCell + <> cell (modal (toWidget iconCompanyWarning) (Right -- TODO: use iconCompanyWarning instead! + [whamlet| +

            + ^{userWidget row} +

            + _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)} + |] + )) + | otherwise = bookLink <> iconCell IconCertificate + in result , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 7cf3d4bca..e5cb7b7ef 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -115,7 +115,7 @@ data Icon | IconRemoveUser | IconReset | IconBlocked - | IconCertificate + | IconCertificate -- currently always a car not always suitable?! | IconPrintCenter | IconLetter -- only to be used for postal matters | IconAt @@ -128,6 +128,7 @@ data Icon | IconUnlocked | IconResetTries -- also see IconReset | IconCompany + | IconCompanyWarning -- Company-related problems | IconEdit | IconUserEdit -- IconMagic -- indicates automatic updates @@ -249,8 +250,8 @@ iconLetterOrEmail True = icon IconLetter iconLetterOrEmail False = icon IconAt iconQualificationBlock :: Bool -> Markup -iconQualificationBlock True = icon IconCertificate -iconQualificationBlock False = icon IconBlocked +iconQualificationBlock True = iconFixed IconCertificate +iconQualificationBlock False = iconFixed IconBlocked iconWriteReadOnly :: Bool -> Markup iconWriteReadOnly True = icon IconEdit From 500c9a749a1e53b1df80d42b0f3dc7dbac8c1ad6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 22 Nov 2024 18:54:08 +0100 Subject: [PATCH 065/187] chore(daily): add suggestions to note fiels (WIP) --- .../courses/tutorial/de-de-formal.msg | 2 +- .../categories/courses/tutorial/en-eu.msg | 2 +- src/Handler/School/DayTasks.hs | 103 +++++++++++++++--- src/Handler/Utils/Form.hs | 2 +- 4 files changed, 89 insertions(+), 20 deletions(-) diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index f1064aa89..bb07d57ba 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -56,4 +56,4 @@ TutorialEyeExam: Sehtest TutorialNote: Kursnotiz TutorialDayAttendance day@Text: Anwesenheit #{day} TutorialDayNote day@Text: Anwesenheitsnotiz für #{day} -TutorialParticipantsDayEdits n@Int: #{tshow n} Kursteilnehmer-Tagesnotizen aktualisiert \ No newline at end of file +TutorialParticipantsDayEdits day@Text: Kursteilnehmer-Tagesnotizen aktualisiert für #{day} \ No newline at end of file diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index b1e027eaa..465b37b9e 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -57,4 +57,4 @@ TutorialEyeExam: Eye exam TutorialNote: Course note TutorialDayAttendance day: Attendance #{day} TutorialDayNote day: Attendance note #{day} -TutorialParticipantsDayEdits n@Int: #{tshow n} course participant day notes updated \ No newline at end of file +TutorialParticipantsDayEdits day: course participant day notes updated for #{day} \ No newline at end of file diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index dd11b28ee..58b916f86 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -33,6 +33,9 @@ import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.)) import Database.Esqueleto.Utils.TH +-- | Maximal number of suggestions for note fields in Day Task view +maxSuggestions :: Int64 +maxSuggestions = 7 -- data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing -- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -246,7 +249,8 @@ eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, Hand eyeExamField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite mkDailyFormColumn :: (RenderMessage UniWorX msg) => Text -> msg -> Lens' DailyTableData a -> ASetter' DailyFormData a -> Field _ a -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) -mkDailyFormColumn k msg lg ls f = sortable (Just $ SortingKey $ stripCI k) (i18nCell msg) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table +mkDailyFormColumn k msg lg ls f = sortable (Just $ SortingKey $ stripCI k) (i18nCell msg) $ formCell + id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(view lg -> x) mkUnique -> over (_1.mapped) (ls .~) . over _2 fvWidget <$> mreq f (fsUniq mkUnique k) (Just x) @@ -256,7 +260,8 @@ colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormRe colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit colParticipantPermitField' :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table +colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell + id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") (Just x) @@ -283,11 +288,53 @@ colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorial colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id (views (resultParticipant . _entityKey) return) - (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique -> - over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$> - mopt textField (fsUniq mkUnique "note-tutorial") (Just note) + (\row mkUnique -> + let note = row ^. resultParticipant . _entityVal . _tutorialParticipantNote + cid = row ^. resultCourse . _entityKey + tid = row ^. resultTutorial . _entityKey + in over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$> + mopt (textField & cfStrip & addDatalist (suggsParticipantNote cid tid)) (fsUniq mkUnique "note-tutorial") (Just note) ) +suggsParticipantNote :: CourseId -> TutorialId -> Handler (OptionList Text) +suggsParticipantNote cid tid = memcachedByHere (Just . Right $ 12 * diffSecond) (cid,tid) $ do -- TODO: better memcached key + let qry = do + (prio, tpn) <- E.from $ TutorialParticipant + ( do + tpa <- E.from $ E.table @TutorialParticipant + E.distinct $ pure () + E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) + E.&&. tpa E.^. TutorialParticipantTutorial E.==. E.val tid + E.limit maxSuggestions + pure (E.val 1, tpa E.^. TutorialParticipantNote) + ) `E.unionAll_` + ( do + (tpa :& tut) <- E.from $ E.table @TutorialParticipant + `E.innerJoin` E.table @Tutorial + `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial) + E.distinct $ pure () + E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) + E.&&. tut E.^. TutorialCourse E.==. E.val cid + E.orderBy [E.desc $ tut E.^. TutorialLastChanged] + E.limit maxSuggestions + pure (E.val 2, tpa E.^. TutorialParticipantNote) + ) `E.unionAll_` + ( do + tpa <- E.from $ E.table @TutorialParticipant + E.distinct $ pure () + E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) + E.limit maxSuggestions + pure (E.val 3, tpa E.^. TutorialParticipantNote) + ) + E.orderBy [E.asc prio, E.asc tpn] + E.limit maxSuggestions + pure tpn + mkOptionsE qry E.unValue (text2message . E.unValue) (toPathPiece . E.unValue) + + +suggsAttentionNote :: Handler (OptionList Textarea) +suggsAttentionNote = error "TODO" + colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id (views (resultParticipant . _entityKey) return) @@ -310,8 +357,16 @@ colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutor colParkingField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParkingField = colParkingField' _dailyFormParkingToken +-- colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +-- colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id +-- (views (resultParticipant . _entityKey) return) +-- (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> +-- over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking +-- ) + colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id +colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell + id -- TODO: this should not be id! Refactor to simplify the thrid argument below (views (resultParticipant . _entityKey) return) (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking @@ -368,16 +423,30 @@ mkDailyTable isAdmin ssh nd = do , Just (unCompanyKey -> csh) <- primComp = bookLink <> spacerCell - <> cell (modal (toWidget iconCompanyWarning) (Right -- TODO: use iconCompanyWarning instead! - [whamlet| -

            - ^{userWidget row} -

            - _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)} - |] - )) - | otherwise = bookLink <> iconCell IconCertificate + <> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] + (Just IconCompanyWarning) True) + | otherwise = bookLink in result + -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row -> + -- let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany + -- primComp = row ^? resultCompanyId + -- bookLink = cellMaybe companyIdCell bookComp + -- warnIcon = \csh -> iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True + -- result + -- | primComp /= bookComp + -- , Just (unCompanyKey -> csh) <- primComp + -- = bookLink + -- <> spacerCell + -- <> cell (modal (warnIcon csh) (Right -- TODO: use iconCompanyWarning instead! + -- [whamlet| + --

            + -- ^{userWidget row} + --

            + -- _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)} + -- |] + -- )) + -- | otherwise = bookLink + -- in result , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn @@ -505,8 +574,8 @@ postSchoolDayR ssh nd = do then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken] - -- TODO: audit log? - addMessageI Success $ MsgTutorialParticipantsDayEdits $ Map.size resMap + -- audit log? Currently decided against. + addMessageI Success $ MsgTutorialParticipantsDayEdits dday redirect $ SchoolR ssh $ SchoolDayR nd siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 65fef8d50..f99b6f37a 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1604,7 +1604,7 @@ mkOptionsE :: forall a r b msg. -> YesodDB UniWorX (OptionList b) mkOptionsE query toExternal toDisplay toInternal = do mr <- getMessageRender - let toOption x = Option <$> (mr <$> toDisplay x) <*> toInternal x <*> toExternal x + let toOption x = (Option . mr <$> toDisplay x) <*> toInternal x <*> toExternal x fmap (mkOptionList . toList) . runConduit $ E.selectSource query .| C.mapM toOption .| C.foldMap Seq.singleton From 564488d5fa81f0c5e3e6cc1ba00a11ce457c3e71 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 25 Nov 2024 11:45:12 +0100 Subject: [PATCH 066/187] chore(day): attempt to fix participant note suggestions --- src/Handler/School/DayTasks.hs | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 58b916f86..3fdf78ee0 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -296,17 +296,24 @@ colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialN mopt (textField & cfStrip & addDatalist (suggsParticipantNote cid tid)) (fsUniq mkUnique "note-tutorial") (Just note) ) +-- deriving instance (Generic a) => Generic (OptionList a) +-- deriving instance (Binary a, Generic a) => Binary (OptionList a) +-- deriving instance Generic (OptionList Text) +-- deriving instance Binary (OptionList Text) +deriving instance Generic (Option Text) +deriving instance Binary (Option Text) + suggsParticipantNote :: CourseId -> TutorialId -> Handler (OptionList Text) -suggsParticipantNote cid tid = memcachedByHere (Just . Right $ 12 * diffSecond) (cid,tid) $ do -- TODO: better memcached key - let qry = do - (prio, tpn) <- E.from $ TutorialParticipant +suggsParticipantNote cid tid = $(memcachedByHere) (Just . Right $ 12 * diffSecond) (cid,tid) $ runDB $ do -- TODO: better memcached key + let qry :: E.SqlQuery (E.SqlExpr (E.Value Text)) = do + (prio, tpn) <- E.from $ ( do tpa <- E.from $ E.table @TutorialParticipant E.distinct $ pure () E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) E.&&. tpa E.^. TutorialParticipantTutorial E.==. E.val tid E.limit maxSuggestions - pure (E.val 1, tpa E.^. TutorialParticipantNote) + pure (E.val (1 :: Int64), tpa E.^. TutorialParticipantNote) ) `E.unionAll_` ( do (tpa :& tut) <- E.from $ E.table @TutorialParticipant @@ -328,8 +335,8 @@ suggsParticipantNote cid tid = memcachedByHere (Just . Right $ 12 * diffSecond) ) E.orderBy [E.asc prio, E.asc tpn] E.limit maxSuggestions - pure tpn - mkOptionsE qry E.unValue (text2message . E.unValue) (toPathPiece . E.unValue) + pure $ E.coalesceDefault [tpn] $ E.val "" + mkOptionsE qry (pure . E.unValue) (pure . text2message . E.unValue) (pure . toPathPiece . E.unValue) suggsAttentionNote :: Handler (OptionList Textarea) From 1f7e9b6a2fae4d2128c50d9c0dbdbbec4d303344 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 26 Nov 2024 18:03:43 +0100 Subject: [PATCH 067/187] chore(daily): adjust css, improve suggestions --- frontend/src/utils/inputs/inputs.sass | 6 +- src/Handler/Admin/Avs.hs | 6 +- src/Handler/Health/Interface.hs | 6 +- src/Handler/Qualification.hs | 6 +- src/Handler/School/DayTasks.hs | 501 +++++++++++++++----------- src/Handler/Utils/Form.hs | 22 ++ src/Utils/Form.hs | 4 + src/Yesod/Form/Types/Instances.hs | 17 +- 8 files changed, 334 insertions(+), 234 deletions(-) diff --git a/frontend/src/utils/inputs/inputs.sass b/frontend/src/utils/inputs/inputs.sass index 8eda7ad8b..fb1a68069 100644 --- a/frontend/src/utils/inputs/inputs.sass +++ b/frontend/src/utils/inputs/inputs.sass @@ -163,7 +163,6 @@ input[type*='time'], // TEXTAREAS textarea width: 100% - height: 170px max-width: 600px line-height: 1.5 color: #363636 @@ -176,6 +175,8 @@ textarea border-radius: 2px box-shadow: inset 0 1px 2px 1px rgba(50, 50, 50, 0.05) vertical-align: top + &:not(.uwx-short) + height: 172px // SHARED STATE RELATED STYLES @@ -211,10 +212,11 @@ option border-radius: 2px outline: 0 color: #363636 - min-width: 250px width: auto background-color: #f3f3f3 box-shadow: inset 0 1px 2px 1px rgba(50, 50, 50, 0.05) + &:not(.uwx-narrow) + min-width: 250px @media (max-width: 425px) select, option diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 853c3450c..bc4489737 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -734,11 +734,9 @@ mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do E.orderBy [E.desc countRows'] E.limit 7 pure (qblock E.^. QualificationUserBlockReason) - mkOption :: E.Value Text -> Option Text - mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } suggestionsBlock :: HandlerFor UniWorX (OptionList Text) - suggestionsBlock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not__) - suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id) + suggestionsBlock = mkOptionListText <$> runDBRead (getBlockReasons E.not__) + suggestionsUnblock = mkOptionListText <$> runDBRead (getBlockReasons id) acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData) acts = mconcat diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index e19945f1b..ccb15ae24 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -308,17 +308,15 @@ wildcardCell c (Just x) = c x mkInterfaceWarnTable :: DB (FormResult (IWTableActionData, Set InterfaceHealthId), Widget) mkInterfaceWarnTable = do let - mkOption :: E.Value Text -> Option Text - mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } getSuggestion pj = E.select $ E.distinct $ do il <- E.from $ E.table @InterfaceLog let res = il E.^. pj E.orderBy [E.asc res] pure res suggestionInterface :: HandlerFor UniWorX (OptionList Text) - suggestionInterface = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogInterface) + suggestionInterface = mkOptionList . fmap mkOptionText <$> runDB (getSuggestion InterfaceLogInterface) suggestionSubtype :: HandlerFor UniWorX (OptionList Text) - suggestionSubtype = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogSubtype) + suggestionSubtype = mkOptionList . fmap mkOptionText <$> runDB (getSuggestion InterfaceLogSubtype) dbtIdent = "interface-warnings" :: Text dbtSQLQuery :: IWTableExpr -> E.SqlQuery IWTableExpr dbtSQLQuery = return diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index e5c872494..62d0e5214 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -538,11 +538,9 @@ postQualificationR sid qsh = do Ex.orderBy [Ex.desc countRows'] Ex.limit 9 pure (qblock Ex.^. QualificationUserBlockReason) - mkOption :: Ex.Value Text -> Option Text - mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } suggestionsBlock :: HandlerFor UniWorX (OptionList Text) - suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_) - suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) + suggestionsBlock = mkOptionListText <$> runDB (getBlockReasons Ex.not_) + suggestionsUnblock = mkOptionListText <$> runDB (getBlockReasons id) dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) acts = mconcat $ diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 3fdf78ee0..1fe505234 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -264,17 +264,17 @@ colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDri id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique -> - over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") (Just x) + over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit" & addClass' "uwx-narrow") (Just x) ) -- Given the row data and a callback to make an input name suitably unique generate the MForm colParticipantEyeExamField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParticipantEyeExamField = colParticipantEyeExamField' _dailyFormEyeExam colParticipantEyeExamField' :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ (cellAttrs <>~ [("style","width:2%")]) <$> formCell id +colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique -> - over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam") (Just x) + over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam" & addClass' "uwx-narrow") (Just x) ) -- colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) @@ -290,75 +290,139 @@ colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialN (views (resultParticipant . _entityKey) return) (\row mkUnique -> let note = row ^. resultParticipant . _entityVal . _tutorialParticipantNote + sid = row ^. resultCourse . _entityVal . _courseSchool cid = row ^. resultCourse . _entityKey tid = row ^. resultTutorial . _entityKey in over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$> - mopt (textField & cfStrip & addDatalist (suggsParticipantNote cid tid)) (fsUniq mkUnique "note-tutorial") (Just note) + mopt (textField & cfStrip & addDatalist (suggsParticipantNote sid cid tid)) (fsUniq mkUnique "note-tutorial") (Just note) ) --- deriving instance (Generic a) => Generic (OptionList a) --- deriving instance (Binary a, Generic a) => Binary (OptionList a) --- deriving instance Generic (OptionList Text) --- deriving instance Binary (OptionList Text) -deriving instance Generic (Option Text) -deriving instance Binary (Option Text) +suggsParticipantNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text) +suggsParticipantNote sid cid tid = do + ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough? + suggs <- runDB $ E.select $ do + let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows + (tpn, prio) <- E.from $ + ( do + tpa <- E.from $ E.table @TutorialParticipant + E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) + E.&&. tpa E.^. TutorialParticipantTutorial E.==. E.val tid + E.groupBy $ tpa E.^. TutorialParticipantNote + E.orderBy [E.desc countRows'] + E.limit maxSuggestions + pure (tpa E.^. TutorialParticipantNote, E.val (1 :: Int64)) + ) `E.unionAll_` + ( do + (tpa :& tut) <- E.from $ E.table @TutorialParticipant + `E.innerJoin` E.table @Tutorial + `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial) + E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) + E.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid + E.&&. tut E.^. TutorialCourse E.==. E.val cid + E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote) + E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] + E.limit maxSuggestions + pure (tpa E.^. TutorialParticipantNote, E.val 2) + ) `E.unionAll_` + ( do + tpa :& tut :& crs <- E.from $ E.table @TutorialParticipant + `E.innerJoin` E.table @Tutorial + `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial) + `E.innerJoin` E.table @Course + `E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId) + E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) + E.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid + E.&&. tut E.^. TutorialCourse E.!=. E.val cid + E.&&. crs E.^. CourseSchool E.==. E.val sid + E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote) + E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] + E.limit maxSuggestions + pure (tpa E.^. TutorialParticipantNote, E.val 3) + ) + E.groupBy (tpn, prio) + E.orderBy [E.asc prio, E.asc tpn] + E.limit maxSuggestions + pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type + -- $logInfoS "NOTE-SUGGS *** A: " $ tshow suggs + pure $ mkOptionListCacheable $ mkOptionText <$> nubOrd suggs + -- $logInfoS "NOTE-SUGGS *** B: " $ tshow ol + pure $ mkOptionListFromCacheable ol -suggsParticipantNote :: CourseId -> TutorialId -> Handler (OptionList Text) -suggsParticipantNote cid tid = $(memcachedByHere) (Just . Right $ 12 * diffSecond) (cid,tid) $ runDB $ do -- TODO: better memcached key - let qry :: E.SqlQuery (E.SqlExpr (E.Value Text)) = do - (prio, tpn) <- E.from $ - ( do - tpa <- E.from $ E.table @TutorialParticipant - E.distinct $ pure () - E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) - E.&&. tpa E.^. TutorialParticipantTutorial E.==. E.val tid - E.limit maxSuggestions - pure (E.val (1 :: Int64), tpa E.^. TutorialParticipantNote) - ) `E.unionAll_` - ( do - (tpa :& tut) <- E.from $ E.table @TutorialParticipant - `E.innerJoin` E.table @Tutorial - `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial) - E.distinct $ pure () - E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) - E.&&. tut E.^. TutorialCourse E.==. E.val cid - E.orderBy [E.desc $ tut E.^. TutorialLastChanged] - E.limit maxSuggestions - pure (E.val 2, tpa E.^. TutorialParticipantNote) - ) `E.unionAll_` - ( do - tpa <- E.from $ E.table @TutorialParticipant - E.distinct $ pure () - E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) - E.limit maxSuggestions - pure (E.val 3, tpa E.^. TutorialParticipantNote) - ) - E.orderBy [E.asc prio, E.asc tpn] - E.limit maxSuggestions - pure $ E.coalesceDefault [tpn] $ E.val "" - mkOptionsE qry (pure . E.unValue) (pure . text2message . E.unValue) (pure . toPathPiece . E.unValue) +suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Textarea) +suggsAttendanceNote sid cid tid = do + ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough? + suggs <- runDB $ E.select $ do + let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows + (tpn, prio) <- E.from $ + ( do + tpa <- E.from $ E.table @TutorialParticipantDay + E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) + E.&&. tpa E.^. TutorialParticipantDayTutorial E.==. E.val tid + E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay) + E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows'] + E.limit maxSuggestions + pure (tpa E.^. TutorialParticipantDayNote, E.val (1 :: Int64)) + -- ) `E.unionAll_` + -- ( do + -- (tpa :& tut) <- E.from $ E.table @TutorialParticipantDay + -- `E.innerJoin` E.table @Tutorial + -- `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial) + -- E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) + -- E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid + -- E.&&. tut E.^. TutorialCourse E.==. E.val cid + -- E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote) + -- E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows'] + -- E.limit maxSuggestions + -- pure (tpa E.^. TutorialParticipantDayNote, E.val 2) + -- ) `E.unionAll_` + -- ( do + -- tpa :& tut :& crs <- E.from $ E.table @TutorialParticipantDay + -- `E.innerJoin` E.table @Tutorial + -- `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial) + -- `E.innerJoin` E.table @Course + -- `E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId) + -- E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) + -- E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid + -- E.&&. tut E.^. TutorialCourse E.!=. E.val cid + -- E.&&. crs E.^. CourseSchool E.==. E.val sid + -- E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote) + -- E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] + -- E.limit maxSuggestions + -- pure (tpa E.^. TutorialParticipantDayNote, E.val 3) + ) + E.groupBy (tpn, prio) + E.orderBy [E.asc prio, E.asc tpn] + E.limit maxSuggestions + pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type + -- $logInfoS "NOTE-SUGGS *** A: " $ tshow suggs + pure $ mkOptionListCacheable $ fmap Textarea . mkOptionText <$> nubOrd suggs -- TODO: datalist does not work on textarea inputs! + -- $logInfoS "NOTE-SUGGS *** B: " $ tshow ol + pure $ mkOptionListFromCacheable ol -suggsAttentionNote :: Handler (OptionList Textarea) -suggsAttentionNote = error "TODO" - colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) -colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id +colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell id (views (resultParticipant . _entityKey) return) (\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique -> over (_1.mapped) (_dailyFormAttendance .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance ) colAttendanceNoteField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) -colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:10%"), ("style","height:200px")]) <$> formCell id +colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ -- (cellAttrs <>~ [("style","width:10%"), ("style","height:200px")]) <$> + formCell id (views (resultParticipant . _entityKey) return) - (\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique -> - over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> - mopt textareaField (fsUniq mkUnique "note-attendance" - -- & addAutosubmit -- submits while typing - & addAttr "cols" "7" - & addAttr "rows" "2" -- does not work if height is set via css (search "170px") - ) (Textarea <<$>> note) + (\row mkUnique -> + let note = row ^? resultParticipantDay . _tutorialParticipantDayNote + sid = row ^. resultCourse . _entityVal . _courseSchool + cid = row ^. resultCourse . _entityKey + tid = row ^. resultTutorial . _entityKey + in over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> + mopt (textareaField & addDatalist (suggsAttendanceNote sid cid tid)) -- TODO: datalist does not work on textarea inputs! + (fsUniq mkUnique "note-attendance" & addClass' "uwx-short" + -- & addAttr "rows" "2" -- does not work without class uwx-short + -- & addAttr "cols" "12" -- let it stretch + -- & addAutosubmit -- submits while typing + ) (Textarea <<$>> note) ) colParkingField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) @@ -372,7 +436,7 @@ colParkingField = colParkingField' _dailyFormParkingToken -- ) colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell +colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell id -- TODO: this should not be id! Refactor to simplify the thrid argument below (views (resultParticipant . _entityKey) return) (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> @@ -380,166 +444,168 @@ colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToke ) mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Widget) -mkDailyTable isAdmin ssh nd = do - tutLessons <- getDayTutorials' ssh (nd,nd) - dday <- formatTime SelFormatDate nd - let - tutIds = Map.keys tutLessons - dbtSQLQuery :: DailyTableExpr -> DailyTableOutput - dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do - EL.on $ tut E.^. TutorialId E.=?. tdy E.?. TutorialParticipantDayTutorial - E.&&. usr E.^. UserId E.=?. tdy E.?. TutorialParticipantDayUser - E.&&. E.val nd E.=?. tdy E.?. TutorialParticipantDayDay - EL.on $ usr E.^. UserId E.=?. udy E.?. UserDayUser - E.&&. E.val nd E.=?. udy E.?. UserDayDay - EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser - EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser - EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial - EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId - E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds - let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do - E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId - let cqQual = cq E.^. CourseQualificationQualification - cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual] - return $ E.arrayAggWith E.AggModeAll cqQual cqOrder - return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications) - dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId) - dbtProj = dbtProjId - dbtColonnade = formColonnade $ mconcat - [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) - sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c - , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row -> - let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh} - = row ^. resultCourse . _entityVal - tutName = row ^. resultTutorial . _entityVal . _tutorialName - in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName - , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons - , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) -> - -- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell - cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons - -- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now - , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell - -- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid - -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid - , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row -> - let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany - primComp = row ^? resultCompanyId - bookLink = cellMaybe companyIdCell bookComp - result - | primComp /= bookComp - , Just (unCompanyKey -> csh) <- primComp - = bookLink - <> spacerCell - <> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] - (Just IconCompanyWarning) True) - | otherwise = bookLink - in result - -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row -> - -- let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany - -- primComp = row ^? resultCompanyId - -- bookLink = cellMaybe companyIdCell bookComp - -- warnIcon = \csh -> iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True - -- result - -- | primComp /= bookComp - -- , Just (unCompanyKey -> csh) <- primComp - -- = bookLink - -- <> spacerCell - -- <> cell (modal (warnIcon csh) (Right -- TODO: use iconCompanyWarning instead! - -- [whamlet| - --

            - -- ^{userWidget row} - --

            - -- _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)} - -- |] - -- )) - -- | otherwise = bookLink - -- in result - , colUserNameModalHdr MsgCourseParticipant ForProfileDataR - , colUserMatriclenr isAdmin - , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn - , colParticipantPermitField - , colParticipantEyeExamField - , colParticipantNoteField - , colAttendanceField dday - , colAttendanceNoteField dday - , colParkingField - -- FOR DEBUGGING ONLY - -- , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell - -- , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell - -- , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell - -- , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell - -- , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell - -- , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell - ] - dbtSorting = Map.fromList - [ sortUserNameLink queryUser - , sortUserMatriclenr queryUser - , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) - , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) - , ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime) - , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany)) - , ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo)) - , ("permit" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit)) - , ("eye-exam" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam)) - , ("note-tutorial" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantNote)) - , ("attendance" , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance)) - , ("note-attend" , SortColumn $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote)) - , ("parking" , SortColumnNullsInv $ queryUserDay >>> (E.?. UserDayParkingToken)) - ] - dbtFilter = Map.fromList - [ fltrUserNameEmail queryUser - , fltrUserMatriclenr queryUser - , ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName)) - , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName)) - , ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser >>> selectCompanyUserPrime) - ] - dbtFilterUI mPrev = mconcat - [ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse) - , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial) - , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompany) - , fltrUserNameEmailUI mPrev - , fltrUserMatriclenrUI mPrev - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} - dbtIdent :: Text - dbtIdent = "daily" - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing - dbtExtraReps = [] - dbtParams = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd } - -- dbtParams = DBParamsForm - -- { dbParamsFormMethod = POST - -- , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute - -- , dbParamsFormAttrs = [] - -- , dbParamsFormSubmit = FormSubmit - -- , dbParamsFormAdditional = \frag -> do - -- let acts :: Map DailyTableAction (AForm Handler DailyTableActionData) - -- acts = mconcat - -- [ singletonMap DailyActDummy $ pure DailyActDummyData - -- ] - -- (actionRes, action) <- multiActionM acts "" Nothing mempty - -- return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) - -- -- , dbParamsFormAdditional - -- -- = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData) - -- -- acts = mconcat - -- -- [ singletonMap DailyActDummy $ pure DailyActDummyData - -- -- ] - -- -- in renderAForm FormStandard - -- -- $ (, mempty) . First . Just - -- -- <$> multiActionA acts (fslI MsgTableAction) Nothing - -- , dbParamsFormEvaluate = liftHandler . runFormPost - -- , dbParamsFormResult = _1 - -- , dbParamsFormIdent = def - -- } - -- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData) - -- -> FormResult ( DailyTableActionData, Set TutorialId) - -- postprocess inp = do - -- (First (Just act), jobMap) <- inp - -- let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap - -- return (act, jobSet) - psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"] - -- over _1 postprocess <$> dbTable psValidator DBTable{..} - dbTable psValidator DBTable{..} +mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case + tutLessons + | Map.null tutLessons -> return (FormMissing, [whamlet|No tutorials on this day|]) + | otherwise -> do + dday <- formatTime SelFormatDate nd + let + tutIds = Map.keys tutLessons + dbtSQLQuery :: DailyTableExpr -> DailyTableOutput + dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do + EL.on $ tut E.^. TutorialId E.=?. tdy E.?. TutorialParticipantDayTutorial + E.&&. usr E.^. UserId E.=?. tdy E.?. TutorialParticipantDayUser + E.&&. E.val nd E.=?. tdy E.?. TutorialParticipantDayDay + EL.on $ usr E.^. UserId E.=?. udy E.?. UserDayUser + E.&&. E.val nd E.=?. udy E.?. UserDayDay + EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser + EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser + EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial + EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId + E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds + let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do + E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId + let cqQual = cq E.^. CourseQualificationQualification + cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual] + return $ E.arrayAggWith E.AggModeAll cqQual cqOrder + return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications) + dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId) + dbtProj = dbtProjId + dbtColonnade = formColonnade $ mconcat + [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) + sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c + , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row -> + let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh} + = row ^. resultCourse . _entityVal + tutName = row ^. resultTutorial . _entityVal . _tutorialName + in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName + , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons + , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) -> + -- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell + cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons + -- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now + , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell + -- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid + -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid + , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row -> + let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany + primComp = row ^? resultCompanyId + bookLink = cellMaybe companyIdCell bookComp + result + | primComp /= bookComp + , Just (unCompanyKey -> csh) <- primComp + = bookLink + <> spacerCell + <> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] + (Just IconCompanyWarning) True) + | otherwise = bookLink + in result + -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row -> + -- let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany + -- primComp = row ^? resultCompanyId + -- bookLink = cellMaybe companyIdCell bookComp + -- warnIcon = \csh -> iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True + -- result + -- | primComp /= bookComp + -- , Just (unCompanyKey -> csh) <- primComp + -- = bookLink + -- <> spacerCell + -- <> cell (modal (warnIcon csh) (Right -- TODO: use iconCompanyWarning instead! + -- [whamlet| + --

            + -- ^{userWidget row} + --

            + -- _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)} + -- |] + -- )) + -- | otherwise = bookLink + -- in result + , colUserNameModalHdr MsgCourseParticipant ForProfileDataR + , colUserMatriclenr isAdmin + , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn + , colParticipantPermitField + , colParticipantEyeExamField + , colParticipantNoteField + , colAttendanceField dday + , colAttendanceNoteField dday + , colParkingField + -- FOR DEBUGGING ONLY + -- , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell + -- , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell + -- , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell + -- , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell + -- , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell + -- , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell + ] + dbtSorting = Map.fromList + [ sortUserNameLink queryUser + , sortUserMatriclenr queryUser + , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) + , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) + , ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime) + , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany)) + , ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo)) + , ("permit" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit)) + , ("eye-exam" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam)) + , ("note-tutorial" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantNote)) + , ("attendance" , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance)) + , ("note-attend" , SortColumn $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote)) + , ("parking" , SortColumnNullsInv $ queryUserDay >>> (E.?. UserDayParkingToken)) + ] + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , fltrUserMatriclenr queryUser + , ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName)) + , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName)) + , ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser >>> selectCompanyUserPrime) + ] + dbtFilterUI mPrev = mconcat + [ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse) + , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial) + , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompany) + , fltrUserNameEmailUI mPrev + , fltrUserMatriclenrUI mPrev + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} + dbtIdent :: Text + dbtIdent = "daily" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + dbtParams = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd } + -- dbtParams = DBParamsForm + -- { dbParamsFormMethod = POST + -- , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute + -- , dbParamsFormAttrs = [] + -- , dbParamsFormSubmit = FormSubmit + -- , dbParamsFormAdditional = \frag -> do + -- let acts :: Map DailyTableAction (AForm Handler DailyTableActionData) + -- acts = mconcat + -- [ singletonMap DailyActDummy $ pure DailyActDummyData + -- ] + -- (actionRes, action) <- multiActionM acts "" Nothing mempty + -- return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) + -- -- , dbParamsFormAdditional + -- -- = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData) + -- -- acts = mconcat + -- -- [ singletonMap DailyActDummy $ pure DailyActDummyData + -- -- ] + -- -- in renderAForm FormStandard + -- -- $ (, mempty) . First . Just + -- -- <$> multiActionA acts (fslI MsgTableAction) Nothing + -- , dbParamsFormEvaluate = liftHandler . runFormPost + -- , dbParamsFormResult = _1 + -- , dbParamsFormIdent = def + -- } + -- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData) + -- -> FormResult ( DailyTableActionData, Set TutorialId) + -- postprocess inp = do + -- (First (Just act), jobMap) <- inp + -- let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap + -- return (act, jobSet) + psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"] + -- over _1 postprocess <$> dbTable psValidator DBTable{..} + dbTable psValidator DBTable{..} getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html @@ -557,6 +623,7 @@ postSchoolDayR ssh nd = do , dailyFormParkingToken = row ^? resultUserDay . _userDayParkingToken & fromMaybe False } (fmap unFormResult -> tableRes,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd + $logInfoS "****DailyTable****" $ tshow tableRes formResult tableRes $ \resMap -> do runDB $ do forM_ (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index f99b6f37a..3557b9c54 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1593,6 +1593,28 @@ optionsPersistCryptoId filts ords toDisplay = do ents <- runDB $ selectList filts ords optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal) +mkOptionText :: E.Value Text -> Option Text +mkOptionText (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } + +mkOptionListText :: [E.Value Text] -> OptionList Text +mkOptionListText = mkOptionList . fmap mkOptionText + +data OptionListCacheable a = OptionListCacheable [Option a] (Map Text a) +deriving instance (Show a) => Show (OptionListCacheable a) +deriving instance Generic (OptionListCacheable Text) +deriving instance Binary (OptionListCacheable Text) +deriving instance Generic (OptionListCacheable Textarea) +deriving instance Binary (OptionListCacheable Textarea) + +mkOptionListCacheable :: [Option a] -> OptionListCacheable a +mkOptionListCacheable ol = OptionListCacheable ol $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) ol + +mkOptionListFromCacheable :: OptionListCacheable a -> OptionList a +mkOptionListFromCacheable (OptionListCacheable ol om) = OptionList + { olOptions = ol + , olReadExternal = flip Map.lookup om + } + mkOptionsE :: forall a r b msg. ( RenderMessage UniWorX msg , E.SqlSelect a r diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 1f88144d6..39f7bf88c 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -185,6 +185,10 @@ addPlaceholder placeholder fs = fs { fsAttrs = (placeholderAttr, placeholder) : addClass :: PathPiece c => c -> FieldSettings site -> FieldSettings site addClass = over _fsAttrs . Yesod.addClass . toPathPiece +-- for convenience +addClass' :: Text -> FieldSettings site -> FieldSettings site +addClass' = addClass + addClasses :: (MonoFoldable mono, PathPiece (Element mono)) => mono -> FieldSettings site -> FieldSettings site addClasses = appEndo . foldMap (Endo . addClass) diff --git a/src/Yesod/Form/Types/Instances.hs b/src/Yesod/Form/Types/Instances.hs index 518fcd9ee..fef720bec 100644 --- a/src/Yesod/Form/Types/Instances.hs +++ b/src/Yesod/Form/Types/Instances.hs @@ -7,10 +7,21 @@ module Yesod.Form.Types.Instances () where -import Yesod.Form.Types - -import Data.Default +import ClassyPrelude.Yesod +-- import Yesod.Form.Types +-- import Data.Default +import Data.Binary instance Default (FieldSettings site) where def = "" + +deriving instance (Show a) => Show (Option a) + +-- to memcache Option Text and Option Textarea +deriving instance Generic (Option Text) +deriving instance Binary (Option Text) + +deriving newtype instance Binary Textarea +deriving instance Generic (Option Textarea) +deriving instance Binary (Option Textarea) \ No newline at end of file From 75a4f52a8070cbc72751f55ccc151e3652ba6202 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 26 Nov 2024 18:03:57 +0100 Subject: [PATCH 068/187] fix(icon): add missing icon --- frontend/src/icons.scss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/frontend/src/icons.scss b/frontend/src/icons.scss index 0392849aa..690aaa6cb 100644 --- a/frontend/src/icons.scss +++ b/frontend/src/icons.scss @@ -5,7 +5,7 @@ @import 'env'; -$ico-width: 30px; +$ico-width: 15px; $icons: new, ok, @@ -95,6 +95,7 @@ $icons: new, trash, reset-tries, company, + company-warning, edit, user-edit, placeholder, @@ -133,6 +134,7 @@ $icons: new, .large-ico { font-size: 2em; + min-width: 1em; } .ico-spin { From 6a0876ae558f54882fac1644cb43099f162ecd12 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 27 Nov 2024 12:56:29 +0100 Subject: [PATCH 069/187] chore(daily): basic functionality #1939 completed and checked - filters now work as intended - textField suggestions now work as intended --- .../categories/courses/courses/en-eu.msg | 2 +- .../courses/tutorial/de-de-formal.msg | 2 +- .../utils/navigation/menu/de-de-formal.msg | 2 +- .../uniworx/utils/navigation/menu/en-eu.msg | 2 +- .../utils/table_column/de-de-formal.msg | 4 +- messages/uniworx/utils/table_column/en-eu.msg | 6 +- src/Handler/School/DayTasks.hs | 128 +++++++++--------- templates/i18n/day-view/de-de-formal.hamlet | 29 ++++ templates/i18n/day-view/en-eu.hamlet | 29 ++++ .../i18n/profile-remarks/de-de-formal.hamlet | 2 + templates/i18n/profile-remarks/en-eu.hamlet | 2 + 11 files changed, 138 insertions(+), 70 deletions(-) create mode 100644 templates/i18n/day-view/de-de-formal.hamlet create mode 100644 templates/i18n/day-view/en-eu.hamlet diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 9f7835095..d71d9178a 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -2,7 +2,7 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later -FilterCourse: Course +FilterCourse: Course type FilterCourseShort: Shorthand FilterTerm: Year FilterCourseSchoolShort: Department diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index bb07d57ba..539f014f0 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -55,5 +55,5 @@ TutorialDrivingPermit: Führerschein TutorialEyeExam: Sehtest TutorialNote: Kursnotiz TutorialDayAttendance day@Text: Anwesenheit #{day} -TutorialDayNote day@Text: Anwesenheitsnotiz für #{day} +TutorialDayNote day@Text: Anwesenheitsnotiz #{day} TutorialParticipantsDayEdits day@Text: Kursteilnehmer-Tagesnotizen aktualisiert für #{day} \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index ae3990d41..f6ab783b9 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -97,7 +97,7 @@ MenuExamOfficeUsers: Benutzer:innen MenuLecturerInvite: Funktionäre hinzufügen MenuSchoolList: Bereiche MenuSchoolNew: Neuen Bereich anlegen -MenuSchoolDay ssh@SchoolId d@Text: #{unSchoolKey ssh} #{d} Tagesansicht +MenuSchoolDay ssh@SchoolId d@Text: #{d} #{unSchoolKey ssh} Tagesansicht MenuExternalExamGrades: Prüfungsleistungen MenuExternalExamUsers: Teilnehmer:innen MenuExternalExamEdit: Bearbeiten diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index c8775ef4e..594f9c320 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -97,7 +97,7 @@ MenuExamOfficeUsers: Users MenuLecturerInvite: Add functionaries MenuSchoolList: Departments MenuSchoolNew: Create new department -MenuSchoolDay ssh d: #{unSchoolKey ssh} #{d} Day +MenuSchoolDay ssh d: #{d} #{unSchoolKey ssh} Agenda MenuExternalExamGrades: Exam results MenuExternalExamUsers: Participants MenuExternalExamEdit: Edit diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index ee6890725..6376747a3 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -80,7 +80,9 @@ TableCompanyFilter: Firma oder Nummer TableCompanyShort: Firmenkürzel TableCompanies: Firmen TablePrimeCompany: Primäre Firma +TablePrimeCompanyShort: Kürzel primäre Firma TableBookingCompany: Buchende Firma +TableBookingCompanyShort: Kürzel buchende Firma TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern TableCompanyUser: Firmenangehöriger @@ -118,4 +120,4 @@ TableFilterCommaName: Mehrere Namen mit Komma trennen. TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. TableUserEdit: Benutzer bearbeiten TableRows: Zeilen -TableUserParkingToken: Parkmarke \ No newline at end of file +TableUserParkingToken day@Text: Parkmarke #{day} \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 0ecdd9a0a..b2066a8d7 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -20,7 +20,7 @@ TableMatrikelNr: AVS person no TableSex: Sex TableBirthday: Birthday TableSchool: Department -TableCourse: Course +TableCourse: Course type TableCourseMembers: Participants TableExamOccurrence: Occurrence/room TableExamName: Name @@ -80,7 +80,9 @@ TableCompanyFilter: Company/Nr TableCompanyShort: Company shorthand TableCompanies: Companies TablePrimeCompany: Primary company +TablePrimeCompanyShort: Primary company shorthand TableBookingCompany: Booking company +TableBookingCompanyShort: Booking company shorthand TableCompanyNo: Company number TableCompanyNos: Company numbers TableCompanyUser: Associate @@ -118,4 +120,4 @@ TableFilterCommaName: Separate names by comma. TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. TableUserEdit: Edit user TableRows: Rows -TableUserParkingToken: Parking token \ No newline at end of file +TableUserParkingToken day: Parking token #{day} \ No newline at end of file diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 1fe505234..707208601 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -191,8 +191,8 @@ queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) queryTutorial = $(sqlMIXproj' ''DailyTableExpr 2) queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant) -queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) -- TODO reify seems problematic for now --- queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3) +queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) +-- queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3) -- reify seems problematic for now queryUser :: DailyTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlMIXproj' ''DailyTableExpr 4) @@ -286,7 +286,8 @@ colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorial -- ) colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) -colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id +colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ -- (cellAttrs <>~ [("style","width:60%")]) <$> + formCell id (views (resultParticipant . _entityKey) return) (\row mkUnique -> let note = row ^. resultParticipant . _entityVal . _tutorialParticipantNote @@ -348,7 +349,7 @@ suggsParticipantNote sid cid tid = do -- $logInfoS "NOTE-SUGGS *** B: " $ tshow ol pure $ mkOptionListFromCacheable ol -suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Textarea) +suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text) suggsAttendanceNote sid cid tid = do ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough? suggs <- runDB $ E.select $ do @@ -362,41 +363,39 @@ suggsAttendanceNote sid cid tid = do E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows'] E.limit maxSuggestions pure (tpa E.^. TutorialParticipantDayNote, E.val (1 :: Int64)) - -- ) `E.unionAll_` - -- ( do - -- (tpa :& tut) <- E.from $ E.table @TutorialParticipantDay - -- `E.innerJoin` E.table @Tutorial - -- `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial) - -- E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) - -- E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid - -- E.&&. tut E.^. TutorialCourse E.==. E.val cid - -- E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote) - -- E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows'] - -- E.limit maxSuggestions - -- pure (tpa E.^. TutorialParticipantDayNote, E.val 2) - -- ) `E.unionAll_` - -- ( do - -- tpa :& tut :& crs <- E.from $ E.table @TutorialParticipantDay - -- `E.innerJoin` E.table @Tutorial - -- `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial) - -- `E.innerJoin` E.table @Course - -- `E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId) - -- E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) - -- E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid - -- E.&&. tut E.^. TutorialCourse E.!=. E.val cid - -- E.&&. crs E.^. CourseSchool E.==. E.val sid - -- E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote) - -- E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] - -- E.limit maxSuggestions - -- pure (tpa E.^. TutorialParticipantDayNote, E.val 3) + ) `E.unionAll_` + ( do + (tpa :& tut) <- E.from $ E.table @TutorialParticipantDay + `E.innerJoin` E.table @Tutorial + `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial) + E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) + E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid + E.&&. tut E.^. TutorialCourse E.==. E.val cid + E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay, tut E.^. TutorialLastChanged) + E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] + E.limit maxSuggestions + pure (tpa E.^. TutorialParticipantDayNote, E.val 2) + ) `E.unionAll_` + ( do + tpa :& tut :& crs <- E.from $ E.table @TutorialParticipantDay + `E.innerJoin` E.table @Tutorial + `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial) + `E.innerJoin` E.table @Course + `E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId) + E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) + E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid + E.&&. tut E.^. TutorialCourse E.!=. E.val cid + E.&&. crs E.^. CourseSchool E.==. E.val sid + E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay, tut E.^. TutorialLastChanged) + E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] + E.limit maxSuggestions + pure (tpa E.^. TutorialParticipantDayNote, E.val 3) ) E.groupBy (tpn, prio) E.orderBy [E.asc prio, E.asc tpn] E.limit maxSuggestions pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type - -- $logInfoS "NOTE-SUGGS *** A: " $ tshow suggs - pure $ mkOptionListCacheable $ fmap Textarea . mkOptionText <$> nubOrd suggs -- TODO: datalist does not work on textarea inputs! - -- $logInfoS "NOTE-SUGGS *** B: " $ tshow ol + pure $ mkOptionListCacheable $ mkOptionText <$> nubOrd suggs -- NOTE: datalist does not work on textarea inputs pure $ mkOptionListFromCacheable ol @@ -416,16 +415,18 @@ colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutor sid = row ^. resultCourse . _entityVal . _courseSchool cid = row ^. resultCourse . _entityKey tid = row ^. resultTutorial . _entityKey - in over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> - mopt (textareaField & addDatalist (suggsAttendanceNote sid cid tid)) -- TODO: datalist does not work on textarea inputs! - (fsUniq mkUnique "note-attendance" & addClass' "uwx-short" - -- & addAttr "rows" "2" -- does not work without class uwx-short - -- & addAttr "cols" "12" -- let it stretch - -- & addAutosubmit -- submits while typing - ) (Textarea <<$>> note) + in over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$> -- For Textarea use: fmap (Text.strip . unTextarea) + mopt (textField & cfStrip & addDatalist (suggsAttendanceNote sid cid tid)) (fsUniq mkUnique "note-attendance") note + ---- Version für Textare + -- mopt (textareaField) -- & addDatalist (suggsAttendanceNote sid cid tid)) -- NOTE: datalist does not work on textarea inputs + -- (fsUniq mkUnique "note-attendance" & addClass' "uwx-short" + -- -- & addAttr "rows" "2" -- does not work without class uwx-short + -- -- & addAttr "cols" "12" -- let it stretch + -- -- & addAutosubmit -- submits while typing + -- ) (Textarea <<$>> note) ) -colParkingField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) +colParkingField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParkingField = colParkingField' _dailyFormParkingToken -- colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) @@ -435,18 +436,18 @@ colParkingField = colParkingField' _dailyFormParkingToken -- over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking -- ) -colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell +colParkingField' :: ASetter' a Bool -> Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) +colParkingField' l dday = sortable (Just "parking") (i18nCell $ MsgTableUserParkingToken dday) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell id -- TODO: this should not be id! Refactor to simplify the thrid argument below (views (resultParticipant . _entityKey) return) (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking ) -mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Widget) +mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Maybe Widget) mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case tutLessons - | Map.null tutLessons -> return (FormMissing, [whamlet|No tutorials on this day|]) + | Map.null tutLessons -> return (FormMissing, Nothing) | otherwise -> do dday <- formatTime SelFormatDate nd let @@ -473,7 +474,7 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) - sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c + sortable (Just "course") (i18nCell MsgTableCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row -> let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh} = row ^. resultCourse . _entityVal @@ -486,8 +487,8 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case -- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell -- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid - -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid - , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row -> + -- , sortable (Just "booking-firm") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid + , sortable (Just "booking-firm") (i18nCell MsgTableBookingCompany) $ \row -> let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany primComp = row ^? resultCompanyId bookLink = cellMaybe companyIdCell bookComp @@ -500,7 +501,7 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case (Just IconCompanyWarning) True) | otherwise = bookLink in result - -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row -> + -- , sortable (Just "booking-firm") (i18nCell MsgTableBookingCompany) $ \row -> -- let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany -- primComp = row ^? resultCompanyId -- bookLink = cellMaybe companyIdCell bookComp @@ -510,7 +511,7 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case -- , Just (unCompanyKey -> csh) <- primComp -- = bookLink -- <> spacerCell - -- <> cell (modal (warnIcon csh) (Right -- TODO: use iconCompanyWarning instead! + -- <> cell (modal (warnIcon csh) (Right -- maybe just use iconCompanyWarning instead of modal? -- [whamlet| --

            -- ^{userWidget row} @@ -528,8 +529,8 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case , colParticipantNoteField , colAttendanceField dday , colAttendanceNoteField dday - , colParkingField - -- FOR DEBUGGING ONLY + , colParkingField dday + -- FOR DEBUGGING ONLY: -- , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell -- , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell -- , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell @@ -543,7 +544,7 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) , ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime) - , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany)) + , ("booking-firm" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany)) , ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo)) , ("permit" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit)) , ("eye-exam" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam)) @@ -557,12 +558,14 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case , fltrUserMatriclenr queryUser , ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName)) , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName)) - , ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser >>> selectCompanyUserPrime) + , ("booking-firm" , FilterColumn . E.mkContainsFilterWith Just $ queryParticipant >>> (E.^. TutorialParticipantCompany)) + , ("user-company" , FilterColumn . E.mkContainsFilterWith Just $ queryUser >>> selectCompanyUserPrime) ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse) , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial) - , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompany) + , prismAForm (singletonFilter "booking-firm" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableBookingCompanyShort) + , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompanyShort) , fltrUserNameEmailUI mPrev , fltrUserMatriclenrUI mPrev ] @@ -605,7 +608,7 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case -- return (act, jobSet) psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"] -- over _1 postprocess <$> dbTable psValidator DBTable{..} - dbTable psValidator DBTable{..} + (over _2 Just) <$> dbTable psValidator DBTable{..} getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html @@ -622,12 +625,12 @@ postSchoolDayR ssh nd = do , dailyFormAttendanceNote = row ^? resultParticipantDay ._tutorialParticipantDayNote . _Just , dailyFormParkingToken = row ^? resultUserDay . _userDayParkingToken & fromMaybe False } - (fmap unFormResult -> tableRes,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd - $logInfoS "****DailyTable****" $ tshow tableRes + (fmap unFormResult -> tableRes, tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd + -- logInfoS "****DailyTable****" $ tshow tableRes formResult tableRes $ \resMap -> do runDB $ do forM_ (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do - -- $logDebugS "TableForm" (tshow dfd) + -- logDebugS "TableForm" (tshow dfd) TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit || tutorialParticipantEyeExam /= dailyFormEyeExam @@ -654,6 +657,5 @@ postSchoolDayR ssh nd = do siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do setTitleI (MsgMenuSchoolDay ssh dday) - [whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)} - ^{tableDaily} - |] + $(i18nWidgetFile "day-view") + diff --git a/templates/i18n/day-view/de-de-formal.hamlet b/templates/i18n/day-view/de-de-formal.hamlet new file mode 100644 index 000000000..ce8f630c5 --- /dev/null +++ b/templates/i18n/day-view/de-de-formal.hamlet @@ -0,0 +1,29 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +$maybe tbl <- tableDaily +
            + ^{tbl} +
            +

            Hinweise zu den Formularspalten +
            +
            + _{MsgTutorialDrivingPermit}, _{MsgTutorialEyeExam}, _{MsgTutorialNote} +
            + Pro Kurs und Teilnehmer wird je ein Wert gespeichert. +
            + _{MsgTutorialDayAttendance mempty}, _{MsgTutorialDayNote mempty} +
            + Pro Tag, Kurs und Teilnehmer wird je ein Wert gespeichert. +
            + _{MsgTableUserParkingToken mempty} +
            + Pro Tag und Teilnehmer wird ein Wert gespeichert, d.h. unabhängig vom Kurs. + \ Daraus folgt, dass die Parkmarke immer in allen Zeilen des gleichen Teilnehmers geändert werden muss. +$nothing +
            + An diesem Tag sind zur Zeit keine Kurse eingetragen. + diff --git a/templates/i18n/day-view/en-eu.hamlet b/templates/i18n/day-view/en-eu.hamlet new file mode 100644 index 000000000..603b66abc --- /dev/null +++ b/templates/i18n/day-view/en-eu.hamlet @@ -0,0 +1,29 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +$maybe tbl <- tableDaily +
            + ^{tbl} +
            +

            Note how form data is saved +
            +
            + _{MsgTutorialDrivingPermit}, _{MsgTutorialEyeExam}, _{MsgTutorialNote} +
            + For each course and participant pairing, one value is stored each. +
            + _{MsgTutorialDayAttendance mempty}, _{MsgTutorialDayNote mempty} +
            + For each day, course and participant, one value is stored each. +
            + _{MsgTableUserParkingToken mempty} +
            + For each day and participant, one value is stored, i.e., indipendant of the course. + \ This requires that a change is performed in all rows of the same participant. +$nothing +
            + No courses are currently scheduled on this day. + diff --git a/templates/i18n/profile-remarks/de-de-formal.hamlet b/templates/i18n/profile-remarks/de-de-formal.hamlet index 443df86aa..e830163e8 100644 --- a/templates/i18n/profile-remarks/de-de-formal.hamlet +++ b/templates/i18n/profile-remarks/de-de-formal.hamlet @@ -11,6 +11,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Nicht aufgeführt sind Zeitstempel mit Benutzerinformationen, z.B. bei der Editierung und Korrektur von Übungen, Kursleiterschaft, Raumbuchungen, etc.
          • Nicht aufgeführt sind die an diesen Benutzer versendeten Benachrichtigungen per E-Mail oder Briefpost. +
          • + Nicht aufgeführt sind personenbezogene Vermerke, z.B. über Anwesenheit, Erhalt von Parkmarken, etc.

          • Sie können die diff --git a/templates/i18n/profile-remarks/en-eu.hamlet b/templates/i18n/profile-remarks/en-eu.hamlet index ee749f36c..c7cc41aef 100644 --- a/templates/i18n/profile-remarks/en-eu.hamlet +++ b/templates/i18n/profile-remarks/en-eu.hamlet @@ -11,6 +11,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Timestamps with user information (e.g. editing of corrections, submission groups, rooms, ...) are not shown here.

          • Sent notifications by email or letter are not shown here. +
          • + Some personal notes (e.g. about attendance, receipt of parking permits, ...) are not shown here."

          • You can request your data be deleted by opening From c08d6ae0d0bc790378927f1bf17a1785742f2a0b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 27 Nov 2024 16:04:34 +0100 Subject: [PATCH 070/187] chore(daily): properly implement note suggestion caching and invalidation --- src/Handler/School/DayTasks.hs | 75 ++++++++++++++++++++-------------- 1 file changed, 45 insertions(+), 30 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 707208601..05e471b74 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -9,6 +9,7 @@ module Handler.School.DayTasks ( getSchoolDayR, postSchoolDayR + , getSchoolDayCheckR ) where import Import @@ -71,15 +72,18 @@ getDayTutorials ssh d = E.unValue <<$>> E.select (do ) -} --- Datatype to be used for memcaching occurrences -data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day) +-- Datatype to be used as key for memcaching DayTask related stuff; note that newtype-CacheKeys are optimized away, so multiple constructors are advisable +data DailyCacheKeys + = CacheKeyTutorialOccurrences SchoolId (Day,Day) + | CacheKeySuggsParticipantNote SchoolId TutorialId + | CacheKeySuggsAttendanceNote SchoolId TutorialId deriving (Eq, Ord, Read, Show, Generic) - deriving anyclass (Hashable, Binary) + deriving anyclass (Hashable, Binary, NFData) getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] getDayTutorials ssh dlimit@(dstart, dend ) | dstart > dend = return mempty - | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do + | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do candidates <- E.select $ do (trm :& crs :& tut) <- E.from $ E.table @Term `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) @@ -300,7 +304,7 @@ colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialN suggsParticipantNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text) suggsParticipantNote sid cid tid = do - ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough? + ol <- memcachedBy (Just . Right $ 2 * diffHour) (CacheKeySuggsParticipantNote sid tid) $ do suggs <- runDB $ E.select $ do let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows (tpn, prio) <- E.from $ @@ -351,7 +355,7 @@ suggsParticipantNote sid cid tid = do suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text) suggsAttendanceNote sid cid tid = do - ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough? + ol <- memcachedBy (Just . Right $ 2* diffHour) (CacheKeySuggsAttendanceNote sid tid) $ do suggs <- runDB $ E.select $ do let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows (tpn, prio) <- E.from $ @@ -608,7 +612,7 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case -- return (act, jobSet) psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"] -- over _1 postprocess <$> dbTable psValidator DBTable{..} - (over _2 Just) <$> dbTable psValidator DBTable{..} + over _2 Just <$> dbTable psValidator DBTable{..} getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html @@ -628,29 +632,32 @@ postSchoolDayR ssh nd = do (fmap unFormResult -> tableRes, tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd -- logInfoS "****DailyTable****" $ tshow tableRes formResult tableRes $ \resMap -> do - runDB $ do - forM_ (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do - -- logDebugS "TableForm" (tshow dfd) - TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated - when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit - || tutorialParticipantEyeExam /= dailyFormEyeExam - || tutorialParticipantNote /= dailyFormParticipantNote) $ - update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit - , TutorialParticipantEyeExam =. dailyFormEyeExam - , TutorialParticipantNote =. dailyFormParticipantNote - ] - let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd - if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote) - then deleteBy tpdUq - else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote) - [ TutorialParticipantDayAttendance =. dailyFormAttendance - , TutorialParticipantDayNote =. dailyFormAttendanceNote - ] - let udUq = UniqueUserDay tutorialParticipantUser nd - updateUserDay = if dailyFormParkingToken - then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued - else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False - updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken] + tuts <- runDB $ forM (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do + -- logDebugS "TableForm" (tshow dfd) + TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated + when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit + || tutorialParticipantEyeExam /= dailyFormEyeExam + || tutorialParticipantNote /= dailyFormParticipantNote) $ + update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit + , TutorialParticipantEyeExam =. dailyFormEyeExam + , TutorialParticipantNote =. dailyFormParticipantNote + ] + let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd + if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote) + then deleteBy tpdUq + else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote) + [ TutorialParticipantDayAttendance =. dailyFormAttendance + , TutorialParticipantDayNote =. dailyFormAttendanceNote + ] + let udUq = UniqueUserDay tutorialParticipantUser nd + updateUserDay = if dailyFormParkingToken + then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued + else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False + updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken] + return $ tutorialParticipantTutorial + forM_ tuts $ \tid -> do + memcachedByInvalidate (CacheKeySuggsParticipantNote ssh tid) $ Proxy @(OptionListCacheable Text) + memcachedByInvalidate (CacheKeySuggsAttendanceNote ssh tid) $ Proxy @(OptionListCacheable Text) -- audit log? Currently decided against. addMessageI Success $ MsgTutorialParticipantsDayEdits dday redirect $ SchoolR ssh $ SchoolDayR nd @@ -659,3 +666,11 @@ postSchoolDayR ssh nd = do setTitleI (MsgMenuSchoolDay ssh dday) $(i18nWidgetFile "day-view") + +getSchoolDayCheckR :: SchoolId -> Day -> Handler Html +getSchoolDayCheckR ssh nd = do + -- isAdmin <- hasReadAccessTo AdminR + dday <- formatTime SelFormatDate nd + siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do + setTitleI (MsgMenuSchoolDay ssh dday) + [whamlet|TODO: this is just a stub.|] \ No newline at end of file From f6c82009ee36be44b0df2b54286e117dac9a5865 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 27 Nov 2024 17:04:35 +0100 Subject: [PATCH 071/187] chore(job): disable jobworkers in development in order to reduce log output --- config/develop-settings.yml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/config/develop-settings.yml b/config/develop-settings.yml index 054a7dfd4..393d11724 100644 --- a/config/develop-settings.yml +++ b/config/develop-settings.yml @@ -19,3 +19,8 @@ avs-licence-synch: # Enqueue at specified hour, a few minutes later job-lms-qualifications-enqueue-hour: 16 job-lms-qualifications-dequeue-hour: 4 + +job-mode: + tag: offload +job-workers: 2 +job-flush-interval: 10 \ No newline at end of file From 07cfc0adcbc80bf41a34880f710bbaf38b36ae28 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 27 Nov 2024 17:12:32 +0100 Subject: [PATCH 072/187] fix(hlint): implement some hlint suggestions --- src/Handler/Admin/Avs.hs | 2 +- src/Handler/Utils/Form.hs | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index bc4489737..57bc37d1a 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -623,7 +623,7 @@ instance HasUser LicenceTableData where mkLicenceTable :: AvsPersonIdMapPersonCard -> Set AvsPersonId -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do (currentRoute, usrHasAvsRerr) <- liftHandler $ (,) - <$> (fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute) + <$> fmap (fromMaybe $ error "mkLicenceTable called from 404-handler") (liftHandler getCurrentRoute) <*> (messageTooltip <$> messageI Error MsgProblemAvsUsrHadR) avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [Asc QualificationName] now <- liftIO getCurrentTime diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 3557b9c54..4d8dae25f 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -669,8 +669,8 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev) actions = Map.fromList [ ( UploadModeNone, pure NoUpload) , ( UploadModeAny - , UploadAny - <$> (fromMaybe False <$> aopt checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (Just $ prev ^? _Just . _uploadUnpackZips)) + , (UploadAny . fromMaybe False + <$> aopt checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (Just $ prev ^? _Just . _uploadUnpackZips)) <*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _uploadExtensionRestriction) <|> fmap Just defaultExtensionRestriction) <*> apopt checkBoxField (fslI MsgUploadAnyEmptyOk & setTooltip MsgUploadAnyEmptyOkTip) (preview (_Just . _uploadEmptyOk) prev <|> Just False) ) @@ -792,8 +792,8 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgUtilExamBonusRule) $ clas actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule) actions = Map.fromList [ ( ExamBonusManual' - , ExamBonusManual - <$> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) + , ExamBonusManual . + fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev) ) , ( ExamBonusPoints' , ExamBonusPoints @@ -2077,7 +2077,7 @@ examPassedGradeField :: forall m. , HandlerSite m ~ UniWorX ) => Field m (Either ExamPassed ExamGrade) -examPassedGradeField = hoistField liftHandler . selectField $ (<>) <$> (fmap Right <$> optionsFinite) <*> (fmap Left <$> optionsFinite) +examPassedGradeField = hoistField liftHandler . selectField $ ((<>) . fmap Right <$> optionsFinite) <*> (fmap Left <$> optionsFinite) examField :: forall m. From d4d915bd60fca5b262334f2d9b280dcbfdc1d56e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 29 Nov 2024 16:19:16 +0100 Subject: [PATCH 073/187] chore(daily): towards #2347 by caching and sorting results --- src/Handler/School/DayTasks.hs | 82 +++++++++++++++++++++++++++++++++- 1 file changed, 81 insertions(+), 1 deletion(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 05e471b74..dc8244a8d 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -77,6 +77,7 @@ data DailyCacheKeys = CacheKeyTutorialOccurrences SchoolId (Day,Day) | CacheKeySuggsParticipantNote SchoolId TutorialId | CacheKeySuggsAttendanceNote SchoolId TutorialId + | CacheKeyTutorialCheckResults SchoolId Day deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Hashable, Binary, NFData) @@ -355,7 +356,7 @@ suggsParticipantNote sid cid tid = do suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text) suggsAttendanceNote sid cid tid = do - ol <- memcachedBy (Just . Right $ 2* diffHour) (CacheKeySuggsAttendanceNote sid tid) $ do + ol <- memcachedBy (Just . Right $ 2 * diffHour) (CacheKeySuggsAttendanceNote sid tid) $ do suggs <- runDB $ E.select $ do let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows (tpn, prio) <- E.from $ @@ -666,10 +667,89 @@ postSchoolDayR ssh nd = do setTitleI (MsgMenuSchoolDay ssh dday) $(i18nWidgetFile "day-view") +-- | A wrapper for several check results on tutorial participants +data DayCheckResult = DayCheckResult + { dcEyeFitsPermit :: Maybe Bool + , dcAvsKnown :: Bool + , dcApronAccess :: Bool + , dcBookingFirmOk :: Bool + } + deriving (Show, Generic, Binary) +dcIsOk :: DayCheckResult -> Bool +dcIsOk (DayCheckResult (Just True) True True True) = True +dcIsOk _ = False + +data DayCheckResults = DayCheckResults + { dcrTimestamp :: UTCTime + , dcrResults :: Map TutorialParticipantId DayCheckResult + } + deriving (Show, Generic, Binary) + +type ParticipantCheckData = (Entity TutorialParticipant, (E.Value UserDisplayName, E.Value UserSurname), E.Value (Maybe AvsPersonId), E.Value (Maybe CompanyName)) + + +dayCheckParticipant :: Map AvsPersonId AvsDataPerson + -> ParticipantCheckData + -> DayCheckResult +dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, (E.Value udn, E.Value usn), E.Value mapi, E.Value mcmp) = + let dcEyeFitsPermit = liftM2 eyeExamFitsDrivingPermit tutorialParticipantEyeExam tutorialParticipantDrivingPermit + (dcAvsKnown, (dcApronAccess, dcBookingFirmOk)) + | Just AvsDataPerson{avsPersonPersonCards = apcs} <- lookupMaybe avsStats mapi + = (True , mapBoth getAny $ foldMap (hasApronAccess &&& fitsBooking mcmp) apcs) + | otherwise + = (False, (False, False)) + in DayCheckResult{..} + where + hasApronAccess :: AvsDataPersonCard -> Any + hasApronAccess AvsDataPersonCard{avsDataValid=True, avsDataCardColor=AvsCardColorGelb} = Any True + hasApronAccess AvsDataPersonCard{avsDataValid=True, avsDataCardColor=AvsCardColorRot} = Any True + hasApronAccess _ = Any False + + fitsBooking :: Maybe CompanyName -> AvsDataPersonCard -> Any + fitsBooking (Just cn) AvsDataPersonCard{avsDataValid=True,avsDataFirm=Just df} = Any $ cn == stripCI df + fitsBooking _ _ = Any False + +-- | Prüft die Teilnehmer der Tagesansicht: AVS online aktualisieren, gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen getSchoolDayCheckR :: SchoolId -> Day -> Handler Html getSchoolDayCheckR ssh nd = do -- isAdmin <- hasReadAccessTo AdminR + (tuts, parts_avs) <- runDB $ do + tuts <- Map.keys <$> getDayTutorials ssh (nd,nd) + -- participants <- selectList [TutorialParticipantTutorial <-. tuts] [] + parts_avs :: [ParticipantCheckData] + <- E.select $ do + (tpa :& usr :& avs :& cmp) <- E.from $ E.table @TutorialParticipant + `E.innerJoin` E.table @User + `E.on` (\(tpa :& usr) -> tpa E.^. TutorialParticipantUser E.==. usr E.^. UserId) + `E.leftJoin` E.table @UserAvs + `E.on` (\(tpa :& _ :& avs) -> tpa E.^. TutorialParticipantUser E.=?. avs E.?. UserAvsUser) + `E.leftJoin` E.table @Company + `E.on` (\(tpa :& _ :& _ :& cmp) -> tpa E.^. TutorialParticipantCompany E.==. cmp E.?. CompanyId) + E.where_ $ tpa E.^. TutorialParticipantTutorial `E.in_` E.vals tuts + -- E.orderBy [E.asc $ tpa E.^. TutorialParticipantTutorial, E.asc $ usr E.^. UserDisplayName] -- order no longer needed + return (tpa, (usr E.^. UserDisplayName, usr E.^. UserSurname), avs E.?. UserAvsPersonId, cmp E.?. CompanyName) + -- additionally queue proper AVS synchs for all users, unless there were already done today + void $ queueAvsUpdateByUID (foldMap (^. _1 . _entityVal . _tutorialParticipantUser . to Set.singleton) parts_avs) (Just nowaday) + return (tuts, parts_avs) + let getApi :: ParticipantCheckData -> Set AvsPersonId + getApi = foldMap Set.singleton . E.unValue . view _3 + avsStats :: Map AvsPersonId AvsDataPerson <- catchAVShandler False False True mempty $ lookupAvsUsers $ foldMap getApi parts_avs -- query AVS, but does not affect DB (no update) + -- gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen + let toPartMap :: ParticipantCheckData -> Map TutorialParticipantId DayCheckResult + toPartMap pcd = Map.singleton (pcd ^. _1 . _entityKey) $ dayCheckParticipant avsStats pcd + particpantResults = foldMap toPartMap parts_avs + memcachedBySet (Just . Right $ 2 * diffHour) (CacheKeyTutorialCheckResults ssh nd) $ DayCheckResults now particpantResults + -- the following is only for displaying results neatly + let sortBadParticipant acc pcd = + let tid = pcd ^. _1 . _entityVal . _tutorialParticipantTutorial + pid = pcd ^. _1 . _entityKey + udn = pcd ^. _2 . _1 . _unValue + ok = maybe False dcIsOk $ Map.lookup pid particpantResults + in if ok then acc else Map.insertWith (<>) tid (Map.singleton (udn,pid) pcd) acc + badTutPartMap :: Map TutorialId (Map (UserDisplayName, TutorialParticipantId) ParticipantCheckData) + badTutPartMap = foldl' sortBadParticipant mempty parts_avs + dday <- formatTime SelFormatDate nd siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do setTitleI (MsgMenuSchoolDay ssh dday) From ad1d235beaddcff58ab6fb131e40cfd0a0ecf2bc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 29 Nov 2024 18:13:30 +0100 Subject: [PATCH 074/187] chore(daily): towards #2347 check complete, except i18n also missing: displaying memcached check results in each line of day view --- assets/icons-src/fontawesome.json | 6 +- frontend/src/icons.scss | 3 + src/Handler/Admin/Test.hs | 2 + src/Handler/School/DayTasks.hs | 95 ++++++++++++++++++++++++------- src/Handler/Utils/Form.hs | 2 +- src/Utils/Icon.hs | 4 ++ 6 files changed, 89 insertions(+), 23 deletions(-) diff --git a/assets/icons-src/fontawesome.json b/assets/icons-src/fontawesome.json index 8323cda98..8a21484c1 100644 --- a/assets/icons-src/fontawesome.json +++ b/assets/icons-src/fontawesome.json @@ -29,6 +29,7 @@ "file-upload": "file-arrow-up", "file-zip": "file-zipper", "file-csv": "file-csv", +"file-missing": "file-circle-minus", "sft-question": "circle-question", "sft-hint": "life-ring", "sft-solution": "circle-exclamation", @@ -97,6 +98,9 @@ "placeholder": "notdef", "reroute": "diamond-turn-right", "top": "award", -"wildcard": "asterisk" +"wildcard": "asterisk", +"user-unknown": "user-slash", +"user-badge": "id-badge", +"glasses": "glasses" } diff --git a/frontend/src/icons.scss b/frontend/src/icons.scss index 690aaa6cb..61c10ea40 100644 --- a/frontend/src/icons.scss +++ b/frontend/src/icons.scss @@ -35,6 +35,7 @@ $icons: new, file-upload, file-zip, file-csv, + file-circle-minus, sft-question, sft-hint, sft-solution, @@ -99,6 +100,8 @@ $icons: new, edit, user-edit, placeholder, + glasses, + id-badge, loading; diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index cbd23f3ae..d5a29b055 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -32,6 +32,8 @@ import qualified Database.Esqueleto.Experimental as E (selectOne, unValue) import qualified Database.Esqueleto.PostgreSQL as E (now_) import qualified Database.Esqueleto.Utils as E (psqlVersion_) +{-# ANN module ("HLint: ignore Functor law" :: String) #-} + -- BEGIN - Buttons needed only here data ButtonCreate = CreateMath | CreateInf | CrashApp -- Dummy for Example deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index dc8244a8d..85ffe29be 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -676,23 +676,19 @@ data DayCheckResult = DayCheckResult } deriving (Show, Generic, Binary) -dcIsOk :: DayCheckResult -> Bool -dcIsOk (DayCheckResult (Just True) True True True) = True -dcIsOk _ = False - data DayCheckResults = DayCheckResults { dcrTimestamp :: UTCTime , dcrResults :: Map TutorialParticipantId DayCheckResult } deriving (Show, Generic, Binary) -type ParticipantCheckData = (Entity TutorialParticipant, (E.Value UserDisplayName, E.Value UserSurname), E.Value (Maybe AvsPersonId), E.Value (Maybe CompanyName)) +type ParticipantCheckData = (Entity TutorialParticipant, UserDisplayName, UserSurname, Maybe AvsPersonId, Maybe CompanyName) dayCheckParticipant :: Map AvsPersonId AvsDataPerson -> ParticipantCheckData -> DayCheckResult -dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, (E.Value udn, E.Value usn), E.Value mapi, E.Value mcmp) = +dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, udn, usn, mapi, mcmp) = let dcEyeFitsPermit = liftM2 eyeExamFitsDrivingPermit tutorialParticipantEyeExam tutorialParticipantDrivingPermit (dcAvsKnown, (dcApronAccess, dcBookingFirmOk)) | Just AvsDataPerson{avsPersonPersonCards = apcs} <- lookupMaybe avsStats mapi @@ -710,15 +706,45 @@ dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, (E.Val fitsBooking (Just cn) AvsDataPersonCard{avsDataValid=True,avsDataFirm=Just df} = Any $ cn == stripCI df fitsBooking _ _ = Any False +dcrIsOk :: DayCheckResult -> Bool +dcrIsOk (DayCheckResult (Just True) True True True) = True +dcrIsOk _ = False + +-- TODO: i18n and use icons to show all results at once +-- TODO: using memcache, display icons in column in daily view, if cache is filled +dcr2widget :: Maybe CompanyName -> DayCheckResult -> Widget +dcr2widget _ DayCheckResult{dcAvsKnown=False} = text2widget "AVS Abfrage fehlgeschlagen" +dcr2widget _ DayCheckResult{dcApronAccess=False} = text2widget "Kein gültiger Ausweis mit Vorfeld-Zugang gefunden" +dcr2widget mcn DayCheckResult{dcBookingFirmOk=False} = [whamlet|Für buchende Firma #{maybeMonoid mcn} liegt kein gültiger Ausweis vor|] +dcr2widget _ DayCheckResult{dcEyeFitsPermit=Nothing} = text2widget "Sehtest oder Führerschein fehlen noch" +dcr2widget _ DayCheckResult{dcEyeFitsPermit=Just False}= text2widget "Sehtest und Führerschein passen nicht zusammen" +dcr2widget _ _ = text2widget "Kein Problem vorhanden" + +-- Alternative version using icons to display everything at once +dcr2widget' :: Maybe CompanyName -> DayCheckResult -> Widget +dcr2widget' mcn DayCheckResult{..} = mconcat [avsChk, apronChk, bookChk, permitChk] + where + mkTooltip ico msg = iconTooltip msg (Just ico) True + + avsChk = guardMonoid (not dcAvsKnown) $ mkTooltip IconUserUnknown (text2widget "AVS Abfrage fehlgeschlagen") + apronChk = guardMonoid (not dcApronAccess) $ mkTooltip IconUserBadge (text2widget "Kein gültiger Ausweis mit Vorfeld-Zugang gefunden") + bookChk = guardMonoid (not dcBookingFirmOk) $ mkTooltip IconCompanyWarning [whamlet|Für buchende Firma #{maybeMonoid mcn} liegt kein gültiger Ausweis vor|] + permitChk | isNothing dcEyeFitsPermit = mkTooltip IconGlasses (text2widget "Sehtest oder Führerschein fehlen noch") + | dcEyeFitsPermit == Just False = mkTooltip IconFileMissing (text2widget "Sehtest und Führerschein passen nicht zusammen") + | otherwise = mempty + + -- | Prüft die Teilnehmer der Tagesansicht: AVS online aktualisieren, gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen getSchoolDayCheckR :: SchoolId -> Day -> Handler Html getSchoolDayCheckR ssh nd = do -- isAdmin <- hasReadAccessTo AdminR + now <- liftIO getCurrentTime + let nowaday = utctDay now + dday <- formatTime SelFormatDate nd + (tuts, parts_avs) <- runDB $ do - tuts <- Map.keys <$> getDayTutorials ssh (nd,nd) - -- participants <- selectList [TutorialParticipantTutorial <-. tuts] [] - parts_avs :: [ParticipantCheckData] - <- E.select $ do + tuts <- getDayTutorials ssh (nd,nd) + parts_avs :: [ParticipantCheckData] <- $(unValueNIs 5 [2..5]) <<$>> E.select (do (tpa :& usr :& avs :& cmp) <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @User `E.on` (\(tpa :& usr) -> tpa E.^. TutorialParticipantUser E.==. usr E.^. UserId) @@ -726,31 +752,58 @@ getSchoolDayCheckR ssh nd = do `E.on` (\(tpa :& _ :& avs) -> tpa E.^. TutorialParticipantUser E.=?. avs E.?. UserAvsUser) `E.leftJoin` E.table @Company `E.on` (\(tpa :& _ :& _ :& cmp) -> tpa E.^. TutorialParticipantCompany E.==. cmp E.?. CompanyId) - E.where_ $ tpa E.^. TutorialParticipantTutorial `E.in_` E.vals tuts + E.where_ $ tpa E.^. TutorialParticipantTutorial `E.in_` E.vals (Map.keys tuts) -- E.orderBy [E.asc $ tpa E.^. TutorialParticipantTutorial, E.asc $ usr E.^. UserDisplayName] -- order no longer needed - return (tpa, (usr E.^. UserDisplayName, usr E.^. UserSurname), avs E.?. UserAvsPersonId, cmp E.?. CompanyName) + return (tpa, usr E.^. UserDisplayName, usr E.^. UserSurname, avs E.?. UserAvsPersonId, cmp E.?. CompanyName) + ) -- additionally queue proper AVS synchs for all users, unless there were already done today void $ queueAvsUpdateByUID (foldMap (^. _1 . _entityVal . _tutorialParticipantUser . to Set.singleton) parts_avs) (Just nowaday) return (tuts, parts_avs) let getApi :: ParticipantCheckData -> Set AvsPersonId - getApi = foldMap Set.singleton . E.unValue . view _3 + getApi = foldMap Set.singleton . view _4 avsStats :: Map AvsPersonId AvsDataPerson <- catchAVShandler False False True mempty $ lookupAvsUsers $ foldMap getApi parts_avs -- query AVS, but does not affect DB (no update) -- gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen let toPartMap :: ParticipantCheckData -> Map TutorialParticipantId DayCheckResult toPartMap pcd = Map.singleton (pcd ^. _1 . _entityKey) $ dayCheckParticipant avsStats pcd - particpantResults = foldMap toPartMap parts_avs - memcachedBySet (Just . Right $ 2 * diffHour) (CacheKeyTutorialCheckResults ssh nd) $ DayCheckResults now particpantResults + participantResults = foldMap toPartMap parts_avs + memcachedBySet (Just . Right $ 2 * diffHour) (CacheKeyTutorialCheckResults ssh nd) $ DayCheckResults now participantResults + -- the following is only for displaying results neatly let sortBadParticipant acc pcd = let tid = pcd ^. _1 . _entityVal . _tutorialParticipantTutorial pid = pcd ^. _1 . _entityKey - udn = pcd ^. _2 . _1 . _unValue - ok = maybe False dcIsOk $ Map.lookup pid particpantResults + udn = pcd ^. _2 + ok = maybe False dcrIsOk $ Map.lookup pid participantResults in if ok then acc else Map.insertWith (<>) tid (Map.singleton (udn,pid) pcd) acc badTutPartMap :: Map TutorialId (Map (UserDisplayName, TutorialParticipantId) ParticipantCheckData) badTutPartMap = foldl' sortBadParticipant mempty parts_avs - dday <- formatTime SelFormatDate nd - siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do - setTitleI (MsgMenuSchoolDay ssh dday) - [whamlet|TODO: this is just a stub.|] \ No newline at end of file + mkBaddieWgt :: TutorialParticipantId -> ParticipantCheckData -> Widget + mkBaddieWgt pid pcd = + let name = nameWidget (pcd ^. _2) (pcd ^. _3) + bookFirm = pcd ^. _5 + problems = maybe (text2widget "???") (dcr2widget bookFirm) (Map.lookup pid participantResults) + problems' = maybe mempty (dcr2widget' bookFirm) (Map.lookup pid participantResults) -- TODO: decide which version to use + in [whamlet|^{name}: ^{problems'} ^{problems}|] + + siteLayoutMsg MsgMenuSchoolDayCheck $ do + setTitleI MsgMenuSchoolDayCheck -- TODO: i18n + [whamlet| +

            + _{MsgMenuSchoolDay ssh dday} +

            + $if Map.null badTutPartMap + Es wurden keine Probleme gefunden. + $else +

            + $forall (tid,badis) <- Map.toList badTutPartMap +
            + #{maybe "???" fst (Map.lookup tid tuts)} +
            +
              + $forall ((udn,pid),pcd) <- Map.toList badis +
            • + ^{mkBaddieWgt pid pcd} +

              + ^{linkButton mempty (text2widget "Schliessen") [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))} + |] \ No newline at end of file diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 4d8dae25f..084874b02 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -180,7 +180,7 @@ instance Button UniWorX ButtonSubmitDelete where nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'" --- | Looks like a button, but is just a link (e.g. for create course, etc.) +-- | Looks like a button, but is just a link (e.g. for create course, etc.), aka btnLink or linkBtn linkButton :: Widget -- ^ Widget to display if unauthorized -> Widget -- ^ Button label -> [ButtonClass UniWorX] diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index e5cb7b7ef..8ca8485ce 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -71,6 +71,7 @@ data Icon | IconFileUpload | IconFileZip | IconFileCSV + | IconFileMissing -- a required document is not on file | IconSFTQuestion -- for SheetFileType only | IconSFTHint -- for SheetFileType only | IconSFTSolution -- for SheetFileType only @@ -135,6 +136,9 @@ data Icon | IconReroute -- for notification rerouting | IconTop -- indicating highest number/quantity/priority for something | IconWildcard + | IconUserUnknown -- no info for user found, e.g. AVS lookup failed + | IconUserBadge -- something about user-avs, e.g. badge in-/valid + | IconGlasses -- user must wear glasses while driving deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) From f47528c7415a8d4007981dece0b4d47b64f8b293 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 2 Dec 2024 13:28:33 +0100 Subject: [PATCH 075/187] chore(daily): fix #2349 completing daily sanity check --- src/Handler/School/DayTasks.hs | 49 +++++++++++++++++++++++++++++----- 1 file changed, 43 insertions(+), 6 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 85ffe29be..bfa6b0773 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -449,8 +449,8 @@ colParkingField' l dday = sortable (Just "parking") (i18nCell $ MsgTableUserPark over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking ) -mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Maybe Widget) -mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case +mkDailyTable :: Bool -> SchoolId -> Day -> Maybe DayCheckResults -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Maybe Widget) +mkDailyTable isAdmin ssh nd dcrs = getDayTutorials ssh (nd,nd) >>= \case tutLessons | Map.null tutLessons -> return (FormMissing, Nothing) | otherwise -> do @@ -500,10 +500,10 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case result | primComp /= bookComp , Just (unCompanyKey -> csh) <- primComp - = bookLink + = cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] + (Just IconCompanyWarning) True) <> spacerCell - <> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] - (Just IconCompanyWarning) True) + <> bookLink | otherwise = bookLink in result -- , sortable (Just "booking-firm") (i18nCell MsgTableBookingCompany) $ \row -> @@ -526,6 +526,9 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case -- )) -- | otherwise = bookLink -- in result + , maybeEmpty dcrs $ \DayCheckResults{..} -> + sortable (Just "check-fail") (timeCell dcrTimestamp) $ \(view $ resultParticipant . _entityKey -> tpid) -> + maybeCell (Map.lookup tpid dcrResults) $ wgtCell . dcr2widget' Nothing , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn @@ -557,6 +560,16 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case , ("attendance" , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance)) , ("note-attend" , SortColumn $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote)) , ("parking" , SortColumnNullsInv $ queryUserDay >>> (E.?. UserDayParkingToken)) + -- , ("check-fail" , SortColumn $ queryParticipant >>> (\pid -> pid E.^. TutorialParticipantId `E.in_` E.vals (maybeEmpty dcrs $ dcrResults >>> Map.keys))) + , let dcrsLevels = maybeEmpty dcrs $ dcrSeverityGroups . dcrResults in + ("check-fail" , SortColumn $ queryParticipant >>> (\((E.^. TutorialParticipantId) -> pid) -> E.case_ + [ E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _1)) E.then_ (E.val 1) + , E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _2)) E.then_ (E.val 2) + , E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _3)) E.then_ (E.val 3) + , E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _4)) E.then_ (E.val 4) + , E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _5)) E.then_ (E.val 5) + ](E.else_ E.val (99 :: Int64)) + )) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser @@ -630,7 +643,8 @@ postSchoolDayR ssh nd = do , dailyFormAttendanceNote = row ^? resultParticipantDay ._tutorialParticipantDayNote . _Just , dailyFormParkingToken = row ^? resultUserDay . _userDayParkingToken & fromMaybe False } - (fmap unFormResult -> tableRes, tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd + dcrs <- memcachedByGet (CacheKeyTutorialCheckResults ssh nd) + (fmap unFormResult -> tableRes, tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd dcrs -- logInfoS "****DailyTable****" $ tshow tableRes formResult tableRes $ \resMap -> do tuts <- runDB $ forM (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do @@ -720,6 +734,29 @@ dcr2widget _ DayCheckResult{dcEyeFitsPermit=Nothing} = text2widget "Sehtest dcr2widget _ DayCheckResult{dcEyeFitsPermit=Just False}= text2widget "Sehtest und Führerschein passen nicht zusammen" dcr2widget _ _ = text2widget "Kein Problem vorhanden" + +dcrSeverity :: DayCheckResult -> Int +dcrSeverity DayCheckResult{dcAvsKnown=False} = 1 +dcrSeverity DayCheckResult{dcApronAccess=False} = 2 +dcrSeverity DayCheckResult{dcBookingFirmOk=False} = 3 +dcrSeverity DayCheckResult{dcEyeFitsPermit=Nothing} = 4 +dcrSeverity DayCheckResult{dcEyeFitsPermit=Just False} = 5 +dcrSeverity _ = 99 + +dcrSeverityGroups :: Map TutorialParticipantId DayCheckResult -> (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId) +dcrSeverityGroups dcrs = Map.foldMapWithKey groupBySeverity mempty + where + groupBySeverity :: TutorialParticipantId -> DayCheckResult -> (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId) + groupBySeverity tpid dcr = + let sempty = mempty :: (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId) + in case dcrSeverity dcr of + 1 -> set _1 (Set.singleton tpid) sempty + 2 -> set _2 (Set.singleton tpid) sempty + 3 -> set _3 (Set.singleton tpid) sempty + 4 -> set _4 (Set.singleton tpid) sempty + 5 -> set _5 (Set.singleton tpid) sempty + _ -> sempty + -- Alternative version using icons to display everything at once dcr2widget' :: Maybe CompanyName -> DayCheckResult -> Widget dcr2widget' mcn DayCheckResult{..} = mconcat [avsChk, apronChk, bookChk, permitChk] From 954e86c95ab160b9b153c929a175aea97ed55068 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 2 Dec 2024 17:38:59 +0100 Subject: [PATCH 076/187] fix(ghci): ghci works now as expected --- Makefile | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 5adf403ea..edc6631ec 100644 --- a/Makefile +++ b/Makefile @@ -266,6 +266,7 @@ endif export DEV_PORT_HTTP=`cat $(CONTAINER_FILE) | grep 'DEV_PORT_HTTP=' | sed 's/DEV_PORT_HTTP=//'`; \ export DEV_PORT_HTTPS=`cat $(CONTAINER_FILE) | grep 'DEV_PORT_HTTPS=' | sed 's/DEV_PORT_HTTPS=//'`; \ export HOST=127.0.0.1 ; \ + export HOST=127.0.0.1 ; \ export PORT=$${PORT:-$${DEV_PORT_HTTP}} ; \ export DETAILED_LOGGING=$${DETAILED_LOGGING:-true} ; \ export LOG_ALL=$${LOG_ALL:-false} ; \ @@ -279,7 +280,7 @@ endif export RIBBON=$${RIBBON:-$${HOST:-localhost}} ; \ export APPROOT=$${APPROOT:-http://localhost:$${DEV_PORT_HTTP}} ; \ export AVSPASS=$${AVSPASS:-nopasswordset} ; \ - stack $(STACK_CORES) exec --local-bin-path $$(pwd)/bin --copy-bins -- yesod devel -p "$${DEV_PORT_HTTP}" -q "$${DEV_PORT_HTTPS}" + stack $(STACK_CORES) exec --local-bin-path $$(pwd)/bin --copy-bins -- yesod devel -n -p "$${DEV_PORT_HTTP}" -q "$${DEV_PORT_HTTPS}" # HELP(compile-backend): compile backend binaries --compile-backend: stack build $(STACK_CORES) --fast --profile --library-profiling --executable-profiling --flag uniworx:-library-only $(--DEVELOPMENT) --local-bin-path $$(pwd)/bin --copy-bins @@ -332,6 +333,7 @@ well-known: static; # HELP(shell-ghci): enter ghci shell. Use "make ghci SRC=" to load specific source modules." --shell-ghci: stack ghci -- $(SRC) + stack ghci -- $(SRC) # --main-is uniworx:exe:uniworx # HELP(shell-{backend,frontend,memcached,minio,postgres}): enter (bash) shell inside a new container of a given service From 6d583fe8c406e28f2a4d67918085a7b95826245f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 2 Dec 2024 17:53:40 +0100 Subject: [PATCH 077/187] fix(icons): fix some botched icon definitions --- frontend/src/icons.scss | 5 +++-- src/Handler/School/DayTasks.hs | 22 +++++++++++----------- 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/frontend/src/icons.scss b/frontend/src/icons.scss index 61c10ea40..e0b3cbf30 100644 --- a/frontend/src/icons.scss +++ b/frontend/src/icons.scss @@ -35,7 +35,7 @@ $icons: new, file-upload, file-zip, file-csv, - file-circle-minus, + file-missing, sft-question, sft-hint, sft-solution, @@ -101,7 +101,8 @@ $icons: new, user-edit, placeholder, glasses, - id-badge, + user-badge, + user-unknown, loading; diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index bfa6b0773..584654635 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -563,12 +563,12 @@ mkDailyTable isAdmin ssh nd dcrs = getDayTutorials ssh (nd,nd) >>= \case -- , ("check-fail" , SortColumn $ queryParticipant >>> (\pid -> pid E.^. TutorialParticipantId `E.in_` E.vals (maybeEmpty dcrs $ dcrResults >>> Map.keys))) , let dcrsLevels = maybeEmpty dcrs $ dcrSeverityGroups . dcrResults in ("check-fail" , SortColumn $ queryParticipant >>> (\((E.^. TutorialParticipantId) -> pid) -> E.case_ - [ E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _1)) E.then_ (E.val 1) - , E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _2)) E.then_ (E.val 2) - , E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _3)) E.then_ (E.val 3) - , E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _4)) E.then_ (E.val 4) - , E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _5)) E.then_ (E.val 5) - ](E.else_ E.val (99 :: Int64)) + [ E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _1)) E.then_ (E.val 1) + , E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _2)) E.then_ (E.val 2) + , E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _3)) E.then_ (E.val 3) + , E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _4)) E.then_ (E.val 4) + , E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _5)) E.then_ (E.val 5) + ] (E.else_ E.val (99 :: Int64)) )) ] dbtFilter = Map.fromList @@ -736,11 +736,11 @@ dcr2widget _ _ = text2widget "Kein Pr dcrSeverity :: DayCheckResult -> Int -dcrSeverity DayCheckResult{dcAvsKnown=False} = 1 -dcrSeverity DayCheckResult{dcApronAccess=False} = 2 -dcrSeverity DayCheckResult{dcBookingFirmOk=False} = 3 -dcrSeverity DayCheckResult{dcEyeFitsPermit=Nothing} = 4 -dcrSeverity DayCheckResult{dcEyeFitsPermit=Just False} = 5 +dcrSeverity DayCheckResult{dcAvsKnown=False} = 1 +dcrSeverity DayCheckResult{dcApronAccess=False} = 2 +dcrSeverity DayCheckResult{dcBookingFirmOk=False} = 3 +dcrSeverity DayCheckResult{dcEyeFitsPermit=Nothing} = 4 +dcrSeverity DayCheckResult{dcEyeFitsPermit=Just False} = 5 dcrSeverity _ = 99 dcrSeverityGroups :: Map TutorialParticipantId DayCheckResult -> (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId) From e53be8ddf9d1bb2163f495e89a8e113b039f7b85 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 2 Dec 2024 18:12:53 +0100 Subject: [PATCH 078/187] fix(icons): fix some botched icon definitions, for real --- src/Handler/School/DayTasks.hs | 9 +++++---- src/Utils/Icon.hs | 12 +++--------- 2 files changed, 8 insertions(+), 13 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 584654635..295dc703a 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -501,7 +501,7 @@ mkDailyTable isAdmin ssh nd dcrs = getDayTutorials ssh (nd,nd) >>= \case | primComp /= bookComp , Just (unCompanyKey -> csh) <- primComp = cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] - (Just IconCompanyWarning) True) + (Just IconCompany) True) <> spacerCell <> bookLink | otherwise = bookLink @@ -532,8 +532,8 @@ mkDailyTable isAdmin ssh nd dcrs = getDayTutorials ssh (nd,nd) >>= \case , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn - , colParticipantPermitField , colParticipantEyeExamField + , colParticipantPermitField , colParticipantNoteField , colAttendanceField dday , colAttendanceNoteField dday @@ -674,6 +674,7 @@ postSchoolDayR ssh nd = do memcachedByInvalidate (CacheKeySuggsParticipantNote ssh tid) $ Proxy @(OptionListCacheable Text) memcachedByInvalidate (CacheKeySuggsAttendanceNote ssh tid) $ Proxy @(OptionListCacheable Text) -- audit log? Currently decided against. + memcachedByInvalidate (CacheKeyTutorialCheckResults ssh nd) $ Proxy @DayCheckResults addMessageI Success $ MsgTutorialParticipantsDayEdits dday redirect $ SchoolR ssh $ SchoolDayR nd @@ -766,8 +767,8 @@ dcr2widget' mcn DayCheckResult{..} = mconcat [avsChk, apronChk, bookChk, permitC avsChk = guardMonoid (not dcAvsKnown) $ mkTooltip IconUserUnknown (text2widget "AVS Abfrage fehlgeschlagen") apronChk = guardMonoid (not dcApronAccess) $ mkTooltip IconUserBadge (text2widget "Kein gültiger Ausweis mit Vorfeld-Zugang gefunden") bookChk = guardMonoid (not dcBookingFirmOk) $ mkTooltip IconCompanyWarning [whamlet|Für buchende Firma #{maybeMonoid mcn} liegt kein gültiger Ausweis vor|] - permitChk | isNothing dcEyeFitsPermit = mkTooltip IconGlasses (text2widget "Sehtest oder Führerschein fehlen noch") - | dcEyeFitsPermit == Just False = mkTooltip IconFileMissing (text2widget "Sehtest und Führerschein passen nicht zusammen") + permitChk | isNothing dcEyeFitsPermit = mkTooltip IconFileMissing (text2widget "Sehtest oder Führerschein fehlen noch") + | dcEyeFitsPermit == Just False = mkTooltip IconGlasses (text2widget "Sehtest und Führerschein passen nicht zusammen") | otherwise = mempty diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 8ca8485ce..aa7576c22 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -29,19 +29,13 @@ type WidgetSiteless = forall site. WidgetFor site () -- We collect all used icons here for an overview. -- For consistency, some conditional icons are also provided, having suffix True/False -{- How to add icons: - - edit utils/rename-fa.json by adding "our-name": "fa-name" - - make sure to only use fontawesome v6.6.0 free icons - - delete directory node_modules --} - - --------------------------------------------------------------------------- -- IMPORTANT: -- All icons must be manually registered within the following files: -- - src/Utils/Icon.hs --- - assets/icon-src/fontawesome.json --- - frontend/src/icons.scss +-- - assets/icon-src/fontawesome.json by adding "our-name": "fa-name" +-- - frontend/src/icons.scss by adding "our-name" +-- We only use fontawesome v6.6.0 free icons in regular and solid --------------------------------------------------------------------------- data Icon = IconNew From b42e93e8918b0c3500ecdfd3e27fa5ecc18548cc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 3 Dec 2024 11:56:48 +0100 Subject: [PATCH 079/187] chore(daily): implement left-over todos and i18n --- .../uniworx/categories/avs/de-de-formal.msg | 13 +- messages/uniworx/categories/avs/en-eu.msg | 7 +- .../courses/tutorial/de-de-formal.msg | 5 +- .../categories/courses/tutorial/en-eu.msg | 5 +- messages/uniworx/misc/de-de-formal.msg | 3 +- messages/uniworx/misc/en-eu.msg | 3 +- .../uniworx/utils/buttons/de-de-formal.msg | 5 +- messages/uniworx/utils/buttons/en-eu.msg | 5 +- src/Handler/School/DayTasks.hs | 145 ++++++++++-------- src/Utils.hs | 1 + 10 files changed, 109 insertions(+), 83 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index fd790cef2..c20485fc6 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Steffen Jost +# SPDX-FileCopyrightText: 2022-24 Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later AvsPersonInfo: AVS Personendaten @@ -54,10 +54,13 @@ AvsUserUnassociated user@UserDisplayName: AVS Id unbekannt für Nutzer #{user} AvsUserUnknownByAvs api@AvsPersonId: AVS kennt Id #{tshow api} nicht (mehr) AvsUserAmbiguous api@AvsPersonId: AVS Id #{tshow api} ist nicht eindeutig AvsStatusSearchEmpty: AVS lieferte keine Ausweisinformationen -AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis -AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse +AvsPersonSearchEmpty: Suche im AVS lieferte kein Ergebnis +AvsPersonSearchAmbiguous: Suche im AVS lieferte mehrere uneindeutige Ergebnisse AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason} AvsIdMismatch api1@AvsPersonId api2@AvsPersonId: AVS Suche für Id #{tshow api1} lieferte stattdessen Id #{tshow api2} AvsUserCreationFailed api@AvsPersonId: Für AVS Id #{tshow api} konnte kein neuer Benutzer angelegt werden, da es eine gemeinsame Id (z.B. Personalnummer) mit einem existierenden, aber verschiedenen Nutzer gibt. -AvsCardsEmpty: AVS Suche lieferte keinerlei Ausweiskarten -AvsCurrentData: Alle angezeigte Daten wurden kürzlich direkt über die AVS Schnittstelle abgerufen. \ No newline at end of file +AvsCardsEmpty: Suche im AVS lieferte keinerlei Ausweiskarten +AvsCurrentData: Alle angezeigte Daten wurden kürzlich direkt über die AVS Schnittstelle abgerufen. + +AvsNoApronCard: Kein gültiger Ausweis mit Vorfeld-Zugang vorhanden +AvsNoCompanyCard mcn@(Maybe CompanyName): Für buchende Firma #{maybeEmpty mcn ciOriginal} liegt kein gültiger Ausweis vor diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index 787d38a16..04cfa7397 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Steffen Jost +# SPDX-FileCopyrightText: 2022-24 Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later AvsPersonInfo: AVS person info @@ -61,4 +61,7 @@ AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{re AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead AvsUserCreationFailed api@AvsPersonId: No new user could be created for AVS Id #{tshow api}, since an existing user shares at least one id presumed as unique AvsCardsEmpty: AVS search returned no id cards -AvsCurrentData: All shown data has been recently received via the AVS interface. \ No newline at end of file +AvsCurrentData: All shown data has been recently received via the AVS interface. + +AvsNoApronCard: No valid card granting apron access found +AvsNoCompanyCard mcn@(Maybe CompanyName): No valid card for booking company #{maybeEmpty mcn ciOriginal} found diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 539f014f0..51d63a9cf 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -56,4 +56,7 @@ TutorialEyeExam: Sehtest TutorialNote: Kursnotiz TutorialDayAttendance day@Text: Anwesenheit #{day} TutorialDayNote day@Text: Anwesenheitsnotiz #{day} -TutorialParticipantsDayEdits day@Text: Kursteilnehmer-Tagesnotizen aktualisiert für #{day} \ No newline at end of file +TutorialParticipantsDayEdits day@Text: Kursteilnehmer-Tagesnotizen aktualisiert für #{day} + +CheckEyePermitMissing: Sehtest oder Führerschein fehlen noch +CheckEyePermitIncompatible: Sehtest und Führerschein passen nicht zusammen \ No newline at end of file diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 465b37b9e..96c044f5d 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -57,4 +57,7 @@ TutorialEyeExam: Eye exam TutorialNote: Course note TutorialDayAttendance day: Attendance #{day} TutorialDayNote day: Attendance note #{day} -TutorialParticipantsDayEdits day: course participant day notes updated for #{day} \ No newline at end of file +TutorialParticipantsDayEdits day: course participant day notes updated for #{day} + +CheckEyePermitMissing: Eye exam or driving permit missing +CheckEyePermitIncompatible: Eye exam and driving permit are incompatible \ No newline at end of file diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index f7cf7a561..fbc36aa90 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -31,4 +31,5 @@ PaginationPage: Angzeigte Seite PaginationError: Paginierung Parameter dürfen nicht negativ sein NullDeletes: Zum Löschen NULL eingeben. -SortPriority: Sortierungspriorität \ No newline at end of file +SortPriority: Sortierungspriorität +NoProblem: Keine Probleme gefunden \ No newline at end of file diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index da5d1efab..05d12945c 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -31,4 +31,5 @@ PaginationPage: Page to show PaginationError: Pagination parameter must not be negative NullDeletes: Enter NULL to delete. -SortPriority: Sort order priority \ No newline at end of file +SortPriority: Sort order priority +NoProblem: No Probleme found \ No newline at end of file diff --git a/messages/uniworx/utils/buttons/de-de-formal.msg b/messages/uniworx/utils/buttons/de-de-formal.msg index 8252a3a1c..7c999bd06 100644 --- a/messages/uniworx/utils/buttons/de-de-formal.msg +++ b/messages/uniworx/utils/buttons/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros ,Sarah Vaupel +# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Winnie Ros ,Sarah Vaupel ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -57,4 +57,5 @@ BtnFinishExam: Prüfungsergebnisse sichtbar schalten BtnConfirm: Bestätigen BtnCourseRegisterAdd: Personen suchen BtnCourseRegisterConfirm: Ausgewählte Personen anmelden -BtnCourseRegisterAbort: Abbrechen \ No newline at end of file +BtnCourseRegisterAbort: Abbrechen +BtnCloseReload: Schließen und aktualisieren \ No newline at end of file diff --git a/messages/uniworx/utils/buttons/en-eu.msg b/messages/uniworx/utils/buttons/en-eu.msg index a83a7b3aa..4d5924f08 100644 --- a/messages/uniworx/utils/buttons/en-eu.msg +++ b/messages/uniworx/utils/buttons/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Steffen Jost ,Winnie Ros ,Sarah Vaupel +# SPDX-FileCopyrightText: 2022-24 Steffen Jost ,Winnie Ros ,Sarah Vaupel ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -57,4 +57,5 @@ BtnFinishExam: Make results visible BtnConfirm: Confirm BtnCourseRegisterAdd: Search persons BtnCourseRegisterConfirm: Register selected persons -BtnCourseRegisterAbort: Abort \ No newline at end of file +BtnCourseRegisterAbort: Abort +BtnCloseReload: Close and reload \ No newline at end of file diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 295dc703a..a0433f6f3 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -4,8 +4,7 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- TODO during development only -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO during development only +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} module Handler.School.DayTasks ( getSchoolDayR, postSchoolDayR @@ -16,7 +15,8 @@ import Import import Handler.Utils import Handler.Utils.Company -import Handler.Utils.Occurrences +-- import Handler.Utils.Occurrences +import Handler.Utils.Avs import qualified Data.Set as Set import qualified Data.Map as Map @@ -29,8 +29,8 @@ import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Legacy as EL (on, from) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Utils as E -import Database.Esqueleto.PostgreSQL.JSON ((@>.)) -import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.)) +-- import Database.Esqueleto.PostgreSQL.JSON ((@>.)) +-- import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.)) import Database.Esqueleto.Utils.TH @@ -528,7 +528,7 @@ mkDailyTable isAdmin ssh nd dcrs = getDayTutorials ssh (nd,nd) >>= \case -- in result , maybeEmpty dcrs $ \DayCheckResults{..} -> sortable (Just "check-fail") (timeCell dcrTimestamp) $ \(view $ resultParticipant . _entityKey -> tpid) -> - maybeCell (Map.lookup tpid dcrResults) $ wgtCell . dcr2widget' Nothing + maybeCell (Map.lookup tpid dcrResults) $ wgtCell . dcr2widgetIcn Nothing , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn @@ -682,6 +682,7 @@ postSchoolDayR ssh nd = do setTitleI (MsgMenuSchoolDay ssh dday) $(i18nWidgetFile "day-view") + -- | A wrapper for several check results on tutorial participants data DayCheckResult = DayCheckResult { dcEyeFitsPermit :: Maybe Bool @@ -689,7 +690,7 @@ data DayCheckResult = DayCheckResult , dcApronAccess :: Bool , dcBookingFirmOk :: Bool } - deriving (Show, Generic, Binary) + deriving (Eq, Show, Generic, Binary) data DayCheckResults = DayCheckResults { dcrTimestamp :: UTCTime @@ -697,13 +698,72 @@ data DayCheckResults = DayCheckResults } deriving (Show, Generic, Binary) -type ParticipantCheckData = (Entity TutorialParticipant, UserDisplayName, UserSurname, Maybe AvsPersonId, Maybe CompanyName) +-- | True iff there is no problem at all +dcrIsOk :: DayCheckResult -> Bool +dcrIsOk (DayCheckResult (Just True) True True True) = True +dcrIsOk _ = False +-- | defines categories on DayCheckResult, implying an ordering, with most severe being least +dcrSeverity :: DayCheckResult -> Int +dcrSeverity DayCheckResult{dcAvsKnown = False } = 1 +dcrSeverity DayCheckResult{dcApronAccess = False } = 2 +dcrSeverity DayCheckResult{dcBookingFirmOk = False } = 3 +dcrSeverity DayCheckResult{dcEyeFitsPermit = Nothing } = 4 +dcrSeverity DayCheckResult{dcEyeFitsPermit = Just False} = 5 +dcrSeverity _ = 99 + +instance Ord DayCheckResult where + compare = compare `on` dcrSeverity + +type DayCheckGroups = ( Set TutorialParticipantId -- 1 severity + , Set TutorialParticipantId -- 2 + , Set TutorialParticipantId -- 3 + , Set TutorialParticipantId -- 4 + , Set TutorialParticipantId -- 5 + ) + +dcrSeverityGroups :: Map TutorialParticipantId DayCheckResult -> DayCheckGroups +dcrSeverityGroups = Map.foldMapWithKey groupBySeverity + where + groupBySeverity :: TutorialParticipantId -> DayCheckResult -> DayCheckGroups + groupBySeverity tpid dcr = + let sempty = mempty :: DayCheckGroups + in case dcrSeverity dcr of + 1 -> set _1 (Set.singleton tpid) sempty + 2 -> set _2 (Set.singleton tpid) sempty + 3 -> set _3 (Set.singleton tpid) sempty + 4 -> set _4 (Set.singleton tpid) sempty + 5 -> set _5 (Set.singleton tpid) sempty + _ -> sempty + +-- | Show most important problem as text +dcr2widgetTxt :: Maybe CompanyName -> DayCheckResult -> Widget +dcr2widgetTxt _ DayCheckResult{dcAvsKnown=False} = i18n MsgAvsPersonSearchEmpty +dcr2widgetTxt _ DayCheckResult{dcApronAccess=False} = i18n MsgAvsNoApronCard +dcr2widgetTxt mcn DayCheckResult{dcBookingFirmOk=False} = i18n $ MsgAvsNoCompanyCard mcn +dcr2widgetTxt _ DayCheckResult{dcEyeFitsPermit=Nothing} = i18n MsgCheckEyePermitMissing +dcr2widgetTxt _ DayCheckResult{dcEyeFitsPermit=Just False}= i18n MsgCheckEyePermitIncompatible +dcr2widgetTxt _ _ = i18n MsgNoProblem + +-- | Show all problems as icon with tooltip +dcr2widgetIcn :: Maybe CompanyName -> DayCheckResult -> Widget +dcr2widgetIcn mcn DayCheckResult{..} = mconcat [avsChk, apronChk, bookChk, permitChk] + where + mkTooltip ico msg = iconTooltip msg (Just ico) True + + avsChk = guardMonoid (not dcAvsKnown) $ mkTooltip IconUserUnknown (i18n MsgAvsPersonSearchEmpty) + apronChk = guardMonoid (not dcApronAccess) $ mkTooltip IconUserBadge (i18n MsgAvsNoApronCard) + bookChk = guardMonoid (not dcBookingFirmOk) $ mkTooltip IconCompanyWarning (i18n $ MsgAvsNoCompanyCard mcn) + permitChk | isNothing dcEyeFitsPermit = mkTooltip IconFileMissing (i18n MsgCheckEyePermitMissing) + | dcEyeFitsPermit == Just False = mkTooltip IconGlasses (i18n MsgCheckEyePermitIncompatible) + | otherwise = mempty + +type ParticipantCheckData = (Entity TutorialParticipant, UserDisplayName, UserSurname, Maybe AvsPersonId, Maybe CompanyName) dayCheckParticipant :: Map AvsPersonId AvsDataPerson -> ParticipantCheckData -> DayCheckResult -dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, udn, usn, mapi, mcmp) = +dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, _udn, _usn, mapi, mcmp) = let dcEyeFitsPermit = liftM2 eyeExamFitsDrivingPermit tutorialParticipantEyeExam tutorialParticipantDrivingPermit (dcAvsKnown, (dcApronAccess, dcBookingFirmOk)) | Just AvsDataPerson{avsPersonPersonCards = apcs} <- lookupMaybe avsStats mapi @@ -721,57 +781,6 @@ dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, udn, u fitsBooking (Just cn) AvsDataPersonCard{avsDataValid=True,avsDataFirm=Just df} = Any $ cn == stripCI df fitsBooking _ _ = Any False -dcrIsOk :: DayCheckResult -> Bool -dcrIsOk (DayCheckResult (Just True) True True True) = True -dcrIsOk _ = False - --- TODO: i18n and use icons to show all results at once --- TODO: using memcache, display icons in column in daily view, if cache is filled -dcr2widget :: Maybe CompanyName -> DayCheckResult -> Widget -dcr2widget _ DayCheckResult{dcAvsKnown=False} = text2widget "AVS Abfrage fehlgeschlagen" -dcr2widget _ DayCheckResult{dcApronAccess=False} = text2widget "Kein gültiger Ausweis mit Vorfeld-Zugang gefunden" -dcr2widget mcn DayCheckResult{dcBookingFirmOk=False} = [whamlet|Für buchende Firma #{maybeMonoid mcn} liegt kein gültiger Ausweis vor|] -dcr2widget _ DayCheckResult{dcEyeFitsPermit=Nothing} = text2widget "Sehtest oder Führerschein fehlen noch" -dcr2widget _ DayCheckResult{dcEyeFitsPermit=Just False}= text2widget "Sehtest und Führerschein passen nicht zusammen" -dcr2widget _ _ = text2widget "Kein Problem vorhanden" - - -dcrSeverity :: DayCheckResult -> Int -dcrSeverity DayCheckResult{dcAvsKnown=False} = 1 -dcrSeverity DayCheckResult{dcApronAccess=False} = 2 -dcrSeverity DayCheckResult{dcBookingFirmOk=False} = 3 -dcrSeverity DayCheckResult{dcEyeFitsPermit=Nothing} = 4 -dcrSeverity DayCheckResult{dcEyeFitsPermit=Just False} = 5 -dcrSeverity _ = 99 - -dcrSeverityGroups :: Map TutorialParticipantId DayCheckResult -> (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId) -dcrSeverityGroups dcrs = Map.foldMapWithKey groupBySeverity mempty - where - groupBySeverity :: TutorialParticipantId -> DayCheckResult -> (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId) - groupBySeverity tpid dcr = - let sempty = mempty :: (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId) - in case dcrSeverity dcr of - 1 -> set _1 (Set.singleton tpid) sempty - 2 -> set _2 (Set.singleton tpid) sempty - 3 -> set _3 (Set.singleton tpid) sempty - 4 -> set _4 (Set.singleton tpid) sempty - 5 -> set _5 (Set.singleton tpid) sempty - _ -> sempty - --- Alternative version using icons to display everything at once -dcr2widget' :: Maybe CompanyName -> DayCheckResult -> Widget -dcr2widget' mcn DayCheckResult{..} = mconcat [avsChk, apronChk, bookChk, permitChk] - where - mkTooltip ico msg = iconTooltip msg (Just ico) True - - avsChk = guardMonoid (not dcAvsKnown) $ mkTooltip IconUserUnknown (text2widget "AVS Abfrage fehlgeschlagen") - apronChk = guardMonoid (not dcApronAccess) $ mkTooltip IconUserBadge (text2widget "Kein gültiger Ausweis mit Vorfeld-Zugang gefunden") - bookChk = guardMonoid (not dcBookingFirmOk) $ mkTooltip IconCompanyWarning [whamlet|Für buchende Firma #{maybeMonoid mcn} liegt kein gültiger Ausweis vor|] - permitChk | isNothing dcEyeFitsPermit = mkTooltip IconFileMissing (text2widget "Sehtest oder Führerschein fehlen noch") - | dcEyeFitsPermit == Just False = mkTooltip IconGlasses (text2widget "Sehtest und Führerschein passen nicht zusammen") - | otherwise = mempty - - -- | Prüft die Teilnehmer der Tagesansicht: AVS online aktualisieren, gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen getSchoolDayCheckR :: SchoolId -> Day -> Handler Html getSchoolDayCheckR ssh nd = do @@ -813,25 +822,25 @@ getSchoolDayCheckR ssh nd = do udn = pcd ^. _2 ok = maybe False dcrIsOk $ Map.lookup pid participantResults in if ok then acc else Map.insertWith (<>) tid (Map.singleton (udn,pid) pcd) acc - badTutPartMap :: Map TutorialId (Map (UserDisplayName, TutorialParticipantId) ParticipantCheckData) + badTutPartMap :: Map TutorialId (Map (UserDisplayName, TutorialParticipantId) ParticipantCheckData) -- UserDisplayName as Key ensures proper sort order badTutPartMap = foldl' sortBadParticipant mempty parts_avs mkBaddieWgt :: TutorialParticipantId -> ParticipantCheckData -> Widget mkBaddieWgt pid pcd = let name = nameWidget (pcd ^. _2) (pcd ^. _3) bookFirm = pcd ^. _5 - problems = maybe (text2widget "???") (dcr2widget bookFirm) (Map.lookup pid participantResults) - problems' = maybe mempty (dcr2widget' bookFirm) (Map.lookup pid participantResults) -- TODO: decide which version to use - in [whamlet|^{name}: ^{problems'} ^{problems}|] + problemText = maybe (text2widget "???") (dcr2widgetTxt bookFirm) (Map.lookup pid participantResults) + problemIcons = maybe mempty (dcr2widgetIcn bookFirm) (Map.lookup pid participantResults) + in [whamlet|^{name}: ^{problemIcons} ^{problemText}|] siteLayoutMsg MsgMenuSchoolDayCheck $ do - setTitleI MsgMenuSchoolDayCheck -- TODO: i18n + setTitleI MsgMenuSchoolDayCheck [whamlet|

              _{MsgMenuSchoolDay ssh dday}

              $if Map.null badTutPartMap - Es wurden keine Probleme gefunden. + _{MsgNoProblem}. $else

              $forall (tid,badis) <- Map.toList badTutPartMap @@ -839,9 +848,9 @@ getSchoolDayCheckR ssh nd = do #{maybe "???" fst (Map.lookup tid tuts)}
                - $forall ((udn,pid),pcd) <- Map.toList badis + $forall ((_udn,pid),pcd) <- Map.toList badis
              • ^{mkBaddieWgt pid pcd}

                - ^{linkButton mempty (text2widget "Schliessen") [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))} + ^{linkButton mempty (i18n MsgBtnCloseReload) [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))} |] \ No newline at end of file diff --git a/src/Utils.hs b/src/Utils.hs index 2b34d3575..67c485fa0 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -420,6 +420,7 @@ int2widget i = [whamlet|#{tshow i}|] word2widget :: Word64 -> WidgetFor site () word2widget i = [whamlet|#{tshow i}|] +-- | for convenience, alternative use Utils.Widgets.i18n directly msg2widget :: RenderMessage site a => a -> WidgetFor site () msg2widget msg = [whamlet|_{msg}|] From 5f3d8a88e2bfa0f7e0be6b383cb7c29ac907c836 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 3 Dec 2024 11:58:30 +0100 Subject: [PATCH 080/187] fix(hlint): implement hlint suggestion --- src/Foundation/SiteLayout.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index de88d07f7..6ddc6a6d6 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -156,7 +156,7 @@ siteLayout' overrideHeading widget = do -- isParent r = r == (fst parents) isAuth <- isJust <$> maybeAuthId - + now <- liftIO getCurrentTime muid <- maybeAuthPair @@ -254,7 +254,7 @@ siteLayout' overrideHeading widget = do forM_ authTagPivots $ \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute])) getMessages - + storedReasonAndToggleRoute <- case mcurrentRoute of (Just (CourseR tid ssh csh _)) -> (, Just . SomeRoute $ CourseR tid ssh csh CFavouriteR) <$> storedFavouriteReason tid ssh csh muid _otherwise -> pure (Nothing, Nothing) @@ -266,8 +266,8 @@ siteLayout' overrideHeading widget = do , nav' , contentHeadline , mmsgs - , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid - , maybe userDefaultTheme userTheme $ view _2 <$> muid + , maybe userDefaultMaxFavouriteTerms (userMaxFavouriteTerms . view _2) muid + , maybe userDefaultTheme (userTheme . view _2) muid , storedReasonAndToggleRoute ) @@ -299,7 +299,7 @@ siteLayout' overrideHeading widget = do | otherwise = Set.drop (Set.size ts - n) ts currentTerms = toTermKeySet $ filter (views (_2 . _Value) . maybe True $ is _FavouriteCurrent) favourites' toTermKeySet = setOf $ folded . _1 . _2 . to unTermKey - + favourites <- fmap catMaybes . forM favourites' $ \(c@(_, tid, ssh, csh), E.Value mFavourite, courseVisible, mayView, mayEdit) -> let courseRoute = CourseR tid ssh csh CShowR favouriteReason = fromMaybe FavouriteCurrent mFavourite @@ -508,7 +508,7 @@ siteLayout' overrideHeading widget = do $(widgetFile "default-layout") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") - + getSystemMessageState :: (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => SystemMessageId -> m UserSystemMessageState getSystemMessageState smId = liftHandler $ do muid <- maybeAuthId @@ -594,7 +594,7 @@ applySystemMessages = maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do -- FIXME: Move headings into their respective handlers - + -- | Method for specifying page heading for handlers that call defaultLayout -- -- All handlers whose code is under our control should use From a1d7f164271903b067a2893c2e5da34eedd65b40 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 4 Dec 2024 11:58:50 +0100 Subject: [PATCH 081/187] fix(fill): exam prefill dates work now --- config/develop-settings.yml | 4 ++-- test/Database/Fill.hs | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/config/develop-settings.yml b/config/develop-settings.yml index 393d11724..369690c9f 100644 --- a/config/develop-settings.yml +++ b/config/develop-settings.yml @@ -22,5 +22,5 @@ job-lms-qualifications-dequeue-hour: 4 job-mode: tag: offload -job-workers: 2 -job-flush-interval: 10 \ No newline at end of file +job-workers: 1 +job-flush-interval: 600 \ No newline at end of file diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 312057cfb..1e3cd7d6b 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1234,13 +1234,13 @@ fillDb = do , examBonusRule = Nothing , examOccurrenceRule = ExamRoomManual , examExamOccurrenceMapping = Nothing - , examVisibleFrom = jtt TermDayStart 0 Nothing toMidnight - , examRegisterFrom = jtt TermDayStart 0 Nothing toMidnight - , examRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight - , examDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , examPublishOccurrenceAssignments = Nothing - , examStart = Just $ toTimeOfDay 16 0 0 secondDay - , examEnd = Just $ toTimeOfDay 16 30 0 secondDay + , examVisibleFrom = jtt TermDayLectureStart 0 Nothing toMidnight + , examRegisterFrom = jtt TermDayLectureStart 0 Nothing toMidnight + , examRegisterTo = jtt TermDayLectureStart 14 Nothing toMidnight + , examDeregisterUntil = jtt TermDayLectureStart 21 Nothing toMidnight + , examStart = jtt TermDayLectureStart 27 Nothing $ toTimeOfDay 16 0 0 + , examEnd = jtt TermDayLectureStart 27 Nothing $ toTimeOfDay 16 30 0 , examFinished = Nothing , examPartsFrom = Nothing , examClosed = Nothing From c2e0f6b2b83a9a433778390aa7d44591c07e174c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 4 Dec 2024 18:10:13 +0100 Subject: [PATCH 082/187] chore(form): add knownUserField accepting known users only --- src/Database/Esqueleto/Utils.hs | 6 ++ src/Handler/Utils/Form.hs | 103 ++++++++++++++++++++++++++++++++ 2 files changed, 109 insertions(+) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 9c09b41f9..3ee7284c9 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -50,6 +50,7 @@ module Database.Esqueleto.Utils , subSelectCountDistinct , selectCountRows, selectCountDistinct , str2text, str2text' + , str2citext , num2text --, text2num , day, day', dayMaybe, interval, diffDays, diffTimes , exprLift @@ -79,6 +80,7 @@ import Database.Esqueleto.Utils.TH import qualified Data.Text as Text import qualified Data.Text.Lazy as Lazy (Text) import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.CaseInsensitive as CI import Crypto.Hash (Digest, SHA256) @@ -537,6 +539,7 @@ strip = E.unsafeSqlFunction "TRIM" infix 4 `ciEq` +-- Note that this function is unnecessary if the DB type is citext ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) ciEq a b = lower a E.==. lower b @@ -750,6 +753,9 @@ str2text = E.unsafeSqlCastAs "text" str2text' :: E.SqlString a => E.SqlExpr (E.Value (Maybe a)) -> E.SqlExpr (E.Value (Maybe Text)) str2text' = E.unsafeSqlCastAs "text" +str2citext :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value (CI.CI Text)) +str2citext = E.unsafeSqlCastAs "citext" + -- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text) num2text = E.unsafeSqlCastAs "text" diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 084874b02..5f0e8d4e5 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1920,6 +1920,109 @@ userField onlySuggested suggestions = Field{..} Nothing -> E.true +knownUserField :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => Bool -- ^ Only resolve suggested users? + -> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users + -> Field m UserId +knownUserField onlySuggested suggestions = Field{..} + where + lookupExpr + | onlySuggested = suggestions + | otherwise = Just $ E.from return + + fieldEnctype = UrlEncoded + fieldView theId name attrs val isReq = do + val' <- case val of + Left t -> return t + Right uid -> case lookupExpr of + Nothing -> return mempty + Just lookupExpr' -> do + dbRes <- liftHandler . runDB . E.select $ do + user <- lookupExpr' + E.where_ $ user E.^. UserId E.==. E.val uid + return $ user E.^. UserEmail + case dbRes of + [E.Value email] -> return $ CI.original email + _other -> return mempty + + datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions + + [whamlet| + $newline never + + |] + + whenIsJust suggestions $ \suggestions' -> do + suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do + user <- suggestions' + return ( E.case_ + [ E.when_ (unique user $ Left UserDisplayEmail) + E.then_ (user E.^. UserDisplayEmail) + , E.when_ (unique user $ Left UserEmail) + E.then_ (user E.^. UserEmail) + ] + ( E.else_ $ user E.^. UserIdent) + , user E.^. UserDisplayName + ) + [whamlet| + $newline never + + $forall (email, dName) <- suggestedEmails +

                _{MsgExamStaff} +
                ^{userIdWidget examinerId} $maybe room <- examRoom
                _{MsgExamRoom}
                ^{roomReferenceShortWidget room} @@ -194,6 +197,8 @@ $if not (null occurrences) _{MsgExamRoomName} \ ^{isVisible False} + $if is _Nothing examExaminer + _{MsgExamStaff} $if is _Nothing examRoom _{MsgExamRoom} $if not examTimes @@ -234,11 +239,21 @@ $if not (null occurrences) _{MsgExamRoomDescription} $forall (occurrence, registered, rCount, showRoom) <- occurrences - $with Entity _occId ExamOccurrence{examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription} <- occurrence + $with Entity _occId ExamOccurrence{examOccurrenceName, examOccurrenceExaminer, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription} <- occurrence $with registerWdgt <- registerWidget (Just occurrence) $if occurrenceNamesShown #{examOccurrenceName} + $if is _Nothing examExaminer + $if showRoom + + $maybe examinerId <- examOccurrenceExaminer + ^{userIdWidget examinerId} + $nothing + _{MsgExamOccurrenceExaminerIsUnset} + $else + + _{MsgExamOccurrenceExaminerIsHidden} $if is _Nothing examRoom $if showRoom diff --git a/templates/widgets/massinput/examRooms/form.hamlet b/templates/widgets/massinput/examRooms/form.hamlet index 784a572d6..2d92479fa 100644 --- a/templates/widgets/massinput/examRooms/form.hamlet +++ b/templates/widgets/massinput/examRooms/form.hamlet @@ -5,6 +5,7 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later #{csrf}^{fvInput eofIdView}^{fvWidget eofNameView} +^{fvWidget eofExaminerView} ^{eofRoomView} ^{fvWidget eofCapacityView} ^{fvWidget eofStartView} diff --git a/templates/widgets/massinput/examRooms/layout.hamlet b/templates/widgets/massinput/examRooms/layout.hamlet index 1c1121c4b..83f365c87 100644 --- a/templates/widgets/massinput/examRooms/layout.hamlet +++ b/templates/widgets/massinput/examRooms/layout.hamlet @@ -10,6 +10,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgExamRoomName} # + + _{MsgExamStaff} _{MsgExamRoom} @@ -22,6 +24,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later + _{MsgExamRoomExaminerTip} _{MsgExamRoomCapacityTip} From aaf72f72556211be1f2331a491c67b5f991f8784 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 12 Dec 2024 18:28:15 +0100 Subject: [PATCH 087/187] chore(exam): show exam occurrences in participants views for tutorial and course --- .../courses/courses/de-de-formal.msg | 1 + .../categories/courses/courses/en-eu.msg | 1 + src/Handler/Course/Users.hs | 27 +++-- src/Handler/Sheet/Form.hs | 10 +- src/Handler/Tutorial/Users.hs | 12 +++ src/Handler/Utils/Form.hs | 98 ++++++++++++------- src/Utils.hs | 3 + src/Utils/DB.hs | 1 + 8 files changed, 107 insertions(+), 46 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index e0c589aba..c92b235e4 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -135,6 +135,7 @@ CourseUserTutorialsDeregistered count@Int64: Teilnehmer:in von #{show count} #{p CourseUserNoTutorialsDeregistered: Teilnehmer:in ist zu keinem der gewählten Kurse angemeldet CourseUserTutorials: Angemeldete Kurse CourseUserExams: Angemeldete Prüfungen +CourseUserExamOccurrences: Termine/Räume CourseUserSheets: Übungsblätter CsvColumnUserName: Voller Name des/der Teilnehmers/Teilnehmerin CsvColumnUserMatriculation: AVS Nummer des/der Teilnehmers/Teilnehmerin diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index d71d9178a..47123b096 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -135,6 +135,7 @@ CourseUserTutorialsDeregistered count: Sucessfully deregistered participant from CourseUserNoTutorialsDeregistered: Participant is not registered for any of the selected courses CourseUserTutorials: Registered courses CourseUserExams: Registered exams +CourseUserExamOccurrences: Occurrences/rooms CourseUserSheets: Exercise sheets CsvColumnUserName: Participant's full name CsvColumnUserMatriculation: Participant's AVS number diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index b5fe6ca51..f2742212f 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -10,6 +10,7 @@ module Handler.Course.Users , postCUsersR, getCUsersR , colUserSex' , colUserQualifications, colUserQualificationBlocked + , colUserExamOccurrences , _userQualifications ) where @@ -95,7 +96,7 @@ type UserTableData = DBRow ( Entity User , Entity CourseParticipant , Maybe CourseUserNoteId , ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial))) - , [Entity Exam] + , ([Entity Exam], [Entity ExamOccurrence]) , Maybe (Entity SubmissionGroup) , Map SheetName (SheetType SqlBackendKey, Maybe Points) , UserTableQualifications @@ -120,7 +121,10 @@ _userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe ( _userTutorials = _dbrOutput . _4 _userExams :: Lens' UserTableData [Entity Exam] -_userExams = _dbrOutput . _5 +_userExams = _dbrOutput . _5 . _1 + +_userExamOccurrences :: Lens' UserTableData [Entity ExamOccurrence] +_userExamOccurrences = _dbrOutput . _5 . _2 _userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup) _userSubmissionGroup = _dbrOutput . _6 . _Just @@ -165,6 +169,13 @@ colUserExams tid ssh csh = sortable (Just "exams") (i18nCell MsgCourseUserExams) (\(Entity _ Exam{..}) -> CExamR tid ssh csh examName EUsersR) (examName . entityVal) +colUserExamOccurrences :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) +colUserExamOccurrences _tid _ssh _csh = sortable (Just "exams") (i18nCell MsgCourseUserExamOccurrences) + $ \(view _userExamOccurrences -> exams') -> + let exams = sortOn (examOccurrenceName . entityVal) exams' + in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) $ listCell exams + (\(Entity _ ExamOccurrence{..}) -> wgtCell [whamlet|#{examOccurrenceName}:^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}|]) + colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserSex' = colUserSex $ hasUser . _userSex @@ -389,8 +400,9 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do courseQualis <- getCourseQualifications cid let cqids = entityKey <$> courseQualis tutorials <- selectList [ TutorialCourse ==. cid ] [] - exams <- selectList [ ExamCourse ==. cid ] [] - sheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] + exams <- selectList [ ExamCourse ==. cid ] [] + exOccs <- selectList [ ExamOccurrenceExam <-. fmap entityKey exams] [ Asc ExamOccurrenceId ] <&> Map.fromAscList . fmap (\ent -> (entityKey ent, ent)) + sheets <- selectList [ SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] personalisedSheets <- E.select . E.from $ \sheet -> do let hasPersonalised = E.exists . E.from $ \psFile -> E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId @@ -432,9 +444,11 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts' - exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams + exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams + -- ocs = filter (\(Entity oId _) -> any ((== Just oId) . examRegistrationOccurrence . entityVal) exams') exOccs + ocs = catMaybes [ Map.lookup oId exOccs | Entity{entityVal=ExamRegistration{examRegistrationOccurrence = Just oId}} <- exams' ] subs = Map.fromList $ map (over (_2 . _2) (views _entityVal submissionRatingPoints <=< assertM (views _entityVal submissionRatingDone)) . over _1 E.unValue . over (_2 . _1) E.unValue) subs' - return (user, participant, userNoteId, tuts, exs, subGroup, subs, qualis) + return (user, participant, userNoteId, tuts, (exs,ocs), subGroup, subs, qualis) dbtColonnade = colChoices dbtSorting = mconcat [ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header @@ -666,6 +680,7 @@ postCUsersR tid ssh csh = do , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh , guardOn hasExams . cap' $ colUserExams tid ssh csh + , guardOn hasExams . cap' $ colUserExamOccurrences tid ssh csh , pure . cap' $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (maybe mempty dateCell . preview (_Just . _userTableRegistration) . assertM' (has $ _userTableParticipant . _entityVal . _courseParticipantState . _CourseParticipantActive)) , pure . cap' $ sortable (Just "state") (i18nCell MsgCourseUserState) (i18nCell . view (_userTableParticipant . _entityVal . _courseParticipantState)) , guardOn (not $ null sheetList) . colUserSheets $ map (sheetName . entityVal) sheetList diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index ee01d5d4e..4bc636607 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -60,7 +60,7 @@ data SheetPersonalisedFilesForm = SheetPersonalisedFilesForm , spffAllowNonPersonalisedSubmission :: Bool } - + getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference) getFtIdMap sId = do allSheetFiles <- E.select . E.from $ \sheetFile -> do @@ -84,7 +84,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS return ((school, mSchoolAuthorshipStatement), course) sheetPersonalisedFilesForm <- makeSheetPersonalisedFilesForm $ template >>= sfPersonalF - let mkSheetForm + let mkSheetForm sfName sfDescription sfRequireExamRegistration @@ -130,7 +130,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS if | isn't _SchoolAuthorshipStatementModeNone schoolSheetAuthorshipStatementMode -> do wformSection MsgSheetAuthorshipStatementSection - let + let reqContentField :: AForm Handler I18nStoredMarkup reqContentField = formResultUnOpt mr' MsgSheetAuthorshipStatementContent `fmapAForm` i18nFieldA htmlField True (\_ -> Nothing) ("authorship-statement" :: Text) @@ -143,7 +143,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS if | not schoolSheetAuthorshipStatementAllowOther -> (pure SheetAuthorshipStatementModeEnabled, pure sfAuthorshipStatementExam', ) - <$> (fmap (traverse $ fmap authorshipStatementDefinitionContent) . traverse forcedContentField $ entityVal <$> mSchoolAuthorshipStatement) + <$> fmap (traverse $ fmap authorshipStatementDefinitionContent) (traverse (forcedContentField . entityVal) mSchoolAuthorshipStatement) | otherwise -> do examOpts <- let examFieldQuery = E.from $ \exam -> do @@ -205,7 +205,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS #{iconFileZip} \ _{MsgSheetPersonalisedFilesDownload} |] - listRoute <- for mbSheet $ \(sheetName -> shn) -> toTextUrl + listRoute <- for mbSheet $ \(sheetName -> shn) -> toTextUrl ( CourseR courseTerm courseSchool courseShorthand CUsersR , [ ("courseUsers-has-personalised-sheet-files" , toPathPiece shn diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 1f068722e..b7dbad725 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -75,6 +75,7 @@ postTUsersR tid ssh csh tutn = do , pure $ colUserMatriclenr isAdmin , pure $ colUserQualifications nowaday , pure $ colUserQualificationBlocked isAdmin nowaday + , pure $ colUserExamOccurrences tid ssh csh ] psValidator = def & defaultSortingByName @@ -87,6 +88,17 @@ postTUsersR tid ssh csh tutn = do csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"] qualOptions = qualificationsOptionList qualifications + -- pick earliest still open associated exam + _mbExam <- selectFirst + (-- ([ExamRegisterTo >=. Just now] ||. [ExamRegisterTo ==. Nothing]) ++ -- Reconsider: only allow exams with open registration? + ([ExamEnd >=. Just now] ||. [ExamEnd ==. Nothing]) ++ + [ ExamStart <=. Just now -- , ExamRegisterFrom <=. Just now + , ExamCourse ==. cid, ExamClosed ==. Nothing, ExamFinished ==. Nothing -- Reconsider: ExamFinished prevents publication of results - do we want this? + ]) [Asc ExamRegisterFrom, Asc ExamStart, Asc ExamRegisterTo, Asc ExamName] -- earliest still open exam + -- pick exam occurrences and tutors + -- TODO: !!!continue here!!! + + -- multiActionAOpts or similar, see FirmAction for another example let acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData) acts = Map.fromList $ diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 0f3e65c0b..73568b24e 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1886,27 +1886,46 @@ userField onlySuggested suggestions = Field{..}