From 8ab170b59a63d82ea9f0467f25b95d410d361561 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 19 Apr 2023 13:51:27 +0000 Subject: [PATCH 01/56] chore: add pointer to yesod ref to stack.yaml --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index f4dc5c9ae..5319eb0a7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -67,7 +67,7 @@ extra-deps: commit: 843683d024f767de236f74d24a3348f69181a720 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb # <- references debug with trace; master ref: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb subdirs: - yesod-core - yesod-static From 050b02e2fab3adfa7fd05ee812deb5af71f6f4f7 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 19 Apr 2023 14:05:00 +0000 Subject: [PATCH 02/56] chore(debug): reference yesod commit with traceStack for debugging --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 5319eb0a7..87f158595 100644 --- a/stack.yaml +++ b/stack.yaml @@ -67,7 +67,7 @@ extra-deps: commit: 843683d024f767de236f74d24a3348f69181a720 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb # <- references debug with trace; master ref: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: 8488711b567420728c28d1dedd77daf28750bfa8 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb subdirs: - yesod-core - yesod-static From fe1feaeb808dd54f330a28340719360657889ebc Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 19 Apr 2023 14:28:43 +0000 Subject: [PATCH 03/56] chore(debug): -fprof and -fprof-auto --- package.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/package.yaml b/package.yaml index 3be4869eb..6654c1913 100644 --- a/package.yaml +++ b/package.yaml @@ -345,6 +345,8 @@ tests: ghc-options: - -fno-warn-orphans - -threaded -rtsopts "-with-rtsopts=-N -T" + - -fprof + - -fprof-auto hlint: main: Hlint.hs other-modules: [] From 36576add315e8c68465c165540a848cad5f4c171 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Apr 2023 14:30:00 +0000 Subject: [PATCH 04/56] chore(debug): bump yesod-core version --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 87f158595..4a42c7424 100644 --- a/stack.yaml +++ b/stack.yaml @@ -67,7 +67,7 @@ extra-deps: commit: 843683d024f767de236f74d24a3348f69181a720 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: 8488711b567420728c28d1dedd77daf28750bfa8 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb + commit: 4b71808e48e7844d78c07a9df0d548f8edaaa5c0 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb subdirs: - yesod-core - yesod-static From 720c331292a8d5de09c27e2ff81a08439fdcdcfc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Apr 2023 14:41:21 +0000 Subject: [PATCH 05/56] chore(debug): bump yesod-core version --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 4a42c7424..466d12f62 100644 --- a/stack.yaml +++ b/stack.yaml @@ -67,7 +67,7 @@ extra-deps: commit: 843683d024f767de236f74d24a3348f69181a720 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: 4b71808e48e7844d78c07a9df0d548f8edaaa5c0 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb + commit: fff180821c18db01a2eef7a830c94c26c3b05011 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb subdirs: - yesod-core - yesod-static From 8b72e867b63d9b7f676cda05ca14188dc7998157 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Apr 2023 14:47:38 +0000 Subject: [PATCH 06/56] chore(debug): bump yesod-core version --- stack.yaml | 2 +- templates/profileData.hamlet | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/stack.yaml b/stack.yaml index 466d12f62..54e068450 100644 --- a/stack.yaml +++ b/stack.yaml @@ -67,7 +67,7 @@ extra-deps: commit: 843683d024f767de236f74d24a3348f69181a720 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: fff180821c18db01a2eef7a830c94c26c3b05011 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb subdirs: - yesod-core - yesod-static diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 87dae8ebb..0c9783fd4 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -65,7 +65,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
#{userEmail} $if not (validEmail' userEmail) - \ ^{messageTooltip tooltipInvalidEmail} + \ ^{messageTooltip tooltipInvalidEmail}
_{MsgAdminUserPinPassword}
From 62cd170da517d2383c31b1081d64d8719cd9abd5 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Apr 2023 16:55:57 +0200 Subject: [PATCH 07/56] chore(debug): update stack.yaml.lock --- stack.yaml.lock | 58 ++++++++++++++++++++++++------------------------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/stack.yaml.lock b/stack.yaml.lock index 709ec0205..cb7c7063a 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -240,12 +240,12 @@ packages: git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: size: 5954 - sha256: bca827b8f5b4b649ef6d8f0e06fc5ae9b825f9def16fb472173d2fbf12fb5dc2 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + sha256: 08c8da10b32c8d9f784238fd87232bf90b752e82f81ef2c52c62210f9aadda9a + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-core git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-static name: yesod-static @@ -254,11 +254,11 @@ packages: pantry-tree: size: 2949 sha256: 32c1608243a5309005ce11e2aa379ac1d6f8c380c529785eb510770118f3da06 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-static git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-persistent name: yesod-persistent @@ -267,11 +267,11 @@ packages: pantry-tree: size: 497 sha256: 3778ef2964e1a3890afc22cc9124eacb40e64b62bed4983a85d3b99897f54c5c - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-persistent git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-newsfeed name: yesod-newsfeed @@ -280,11 +280,11 @@ packages: pantry-tree: size: 488 sha256: 53ebad62655863a657dcf749ffd3de46f6af90dd71f55bc4d50805ac48ddb099 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-newsfeed git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-form name: yesod-form @@ -293,11 +293,11 @@ packages: pantry-tree: size: 1914 sha256: 260b7f16a8e1d58da137eb91aeed3a11ccbe59ba3e614457a635b9dc3e71426f - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-form git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-form-multi name: yesod-form-multi @@ -306,11 +306,11 @@ packages: pantry-tree: size: 328 sha256: b21fc50db43733dfe6e285345856610ba4feb83329e9cf953bf8047ba18ecbd6 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-form-multi git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-auth name: yesod-auth @@ -319,11 +319,11 @@ packages: pantry-tree: size: 1212 sha256: d335b940a207f8155f421b7146746a72d20db6ad54412154f2c829a59bf21e08 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-auth git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-auth-oauth name: yesod-auth-oauth @@ -332,11 +332,11 @@ packages: pantry-tree: size: 321 sha256: 39d2f7d5d1abb3a2953858c5f23880e60ecfcdad0549ddc2570204f9c47649f4 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-auth-oauth git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-sitemap name: yesod-sitemap @@ -345,11 +345,11 @@ packages: pantry-tree: size: 314 sha256: 971f48af7011ff7816872d067e5de9cadafdd371bdf209170b77df36001abd27 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-sitemap git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-test name: yesod-test @@ -358,11 +358,11 @@ packages: pantry-tree: size: 563 sha256: 3d5022e8e3f8e77abcf075c42cf49efaa26f4951159bbb5ab50b69fdfeacb7c1 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-test git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-bin name: yesod-bin @@ -371,11 +371,11 @@ packages: pantry-tree: size: 1295 sha256: 422d7816965b79826c6c24582d76dadbacd1bfb3e9a8f31208867cd788f2a5b8 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-bin git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod name: yesod @@ -384,11 +384,11 @@ packages: pantry-tree: size: 666 sha256: cb53ef3f2036185d2b4752d6fbc5d78470b4504e646e7eb4dd2397f2599daf42 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-eventsource name: yesod-eventsource @@ -397,11 +397,11 @@ packages: pantry-tree: size: 324 sha256: 6d393201852cd024e377159ba836398e24d191563e08165430113d3c1384aff2 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-eventsource git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: subdir: yesod-websockets name: yesod-websockets @@ -410,11 +410,11 @@ packages: pantry-tree: size: 485 sha256: 02df6117e9b74a77879ea750130ba2d8ad8d3c99e14ca678320cb578984301e5 - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 original: subdir: yesod-websockets git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git - commit: cb75192e0c5490246ae2cbcc2a00e7985cf2aadb + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - completed: name: cryptonite version: '0.29' From 96b5ce4ab0fac359a1fe59184e1aa955de5ec1a1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Apr 2023 15:25:01 +0000 Subject: [PATCH 08/56] chore(build): fix ghc options --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 6654c1913..4969e3422 100644 --- a/package.yaml +++ b/package.yaml @@ -345,7 +345,7 @@ tests: ghc-options: - -fno-warn-orphans - -threaded -rtsopts "-with-rtsopts=-N -T" - - -fprof + - -prof - -fprof-auto hlint: main: Hlint.hs From c7f8663f7150f8eea75b163704ec352fa09c9528 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Apr 2023 15:27:48 +0000 Subject: [PATCH 09/56] chore(build): fix ghc options --- package.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 4969e3422..3b250dd6b 100644 --- a/package.yaml +++ b/package.yaml @@ -256,6 +256,8 @@ ghc-options: - -fno-max-relevant-binds - -j - -freduction-depth=0 + - -prof + - -fprof-auto when: - condition: flag(pedantic) ghc-options: @@ -345,8 +347,6 @@ tests: ghc-options: - -fno-warn-orphans - -threaded -rtsopts "-with-rtsopts=-N -T" - - -prof - - -fprof-auto hlint: main: Hlint.hs other-modules: [] From dfd0f57f9032325ce8c7afe1b77c7a309ae27b78 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Apr 2023 15:57:02 +0000 Subject: [PATCH 10/56] chore(build): add profiling options --- build.sh | 2 +- package.yaml | 2 +- stack.yaml | 7 +++++-- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/build.sh b/build.sh index cf93767e7..0fe066222 100755 --- a/build.sh +++ b/build.sh @@ -9,5 +9,5 @@ set -e [ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || : echo "Building..." -stack build --fast --flag uniworx:-library-only --flag uniworx:dev $@ +stack build --fast --profile --library-profiling --executable-profiling --flag uniworx:-library-only --flag uniworx:dev $@ echo "Done." diff --git a/package.yaml b/package.yaml index 3b250dd6b..93685ee45 100644 --- a/package.yaml +++ b/package.yaml @@ -257,7 +257,7 @@ ghc-options: - -j - -freduction-depth=0 - -prof - - -fprof-auto + - -fprof-auto-call when: - condition: flag(pedantic) ghc-options: diff --git a/stack.yaml b/stack.yaml index 54e068450..e3b41af26 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,8 +7,11 @@ flags: cffi: true rebuild-ghc-options: true -ghc-options: - "$everything": -fno-prof-auto +#ghc-options: +# "$everything": -fno-prof-auto + +library-profiling: true +executable-profiling: true nix: packages: [] From 791220fb029fdf0bfa11963bf7b8f1f187d9d2ac Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 20 Apr 2023 14:58:01 +0200 Subject: [PATCH 11/56] chore(debug): enable profiling properly --- package.yaml | 5 ++--- src/Handler/Admin/Test.hs | 3 ++- stack.yaml | 5 +++-- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/package.yaml b/package.yaml index 93685ee45..08a3b8edc 100644 --- a/package.yaml +++ b/package.yaml @@ -255,9 +255,8 @@ ghc-options: - -fno-warn-partial-type-signatures - -fno-max-relevant-binds - -j - - -freduction-depth=0 - - -prof - - -fprof-auto-call + - -freduction-depth=0 + - -fprof-auto-calls when: - condition: flag(pedantic) ghc-options: diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index ca0d2aae8..ca100366b 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -14,6 +14,7 @@ import Utils.Print import Handler.Utils import Jobs +import Data.Ratio ((%)) import Data.Char (isDigit) import qualified Data.Text as Text -- import qualified Data.Text.IO as Text @@ -97,7 +98,7 @@ postAdminTestR = do case btnResult of (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" - (FormSuccess CrashApp) -> addMessage Error "Crash Button betätigt" >> error "Crash Button" + (FormSuccess CrashApp) -> addMessage Error "Crash Button Ratio 0 betätigt" >> error ("Crash Button" <> (show $ 1 % 0)) FormMissing -> return () _other -> addMessage Warning "KEIN Knopf erkannt" diff --git a/stack.yaml b/stack.yaml index e3b41af26..2c7b72c31 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,8 +10,9 @@ rebuild-ghc-options: true #ghc-options: # "$everything": -fno-prof-auto -library-profiling: true -executable-profiling: true +build: + library-profiling: true + executable-profiling: true nix: packages: [] From b3c083f4d41f0c3c273a49081b38f410a056a8da Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 20 Apr 2023 19:13:55 +0200 Subject: [PATCH 12/56] chore(debug): add rts option for stack trace --- package.yaml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 08a3b8edc..99c9bb23d 100644 --- a/package.yaml +++ b/package.yaml @@ -262,6 +262,7 @@ when: ghc-options: - -Werror - -fwarn-tabs + - +RTS -K0 -xc -RTS - condition: flag(dev) then: ghc-options: @@ -274,7 +275,7 @@ when: ghc-options: - -O - -fllvm - - +RTS -K0 -RTS + - +RTS -K0 -xc -RTS data-files: - testdata/** library: From b74477e67fd38117f0465990347fae138153393c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 20 Apr 2023 19:24:06 +0200 Subject: [PATCH 13/56] Revert "chore(debug): add rts option for stack trace" This reverts commit b3c083f4d41f0c3c273a49081b38f410a056a8da. --- package.yaml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 99c9bb23d..08a3b8edc 100644 --- a/package.yaml +++ b/package.yaml @@ -262,7 +262,6 @@ when: ghc-options: - -Werror - -fwarn-tabs - - +RTS -K0 -xc -RTS - condition: flag(dev) then: ghc-options: @@ -275,7 +274,7 @@ when: ghc-options: - -O - -fllvm - - +RTS -K0 -xc -RTS + - +RTS -K0 -RTS data-files: - testdata/** library: From 02bf1d9a2ca433e55cf7d1e06f0ff300b53c7efb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 24 Apr 2023 13:22:04 +0200 Subject: [PATCH 14/56] fix(build): minor move parenthesis to make linter happy --- src/Handler/Admin/Test.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index ca100366b..7d80b6fc8 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -98,7 +98,7 @@ postAdminTestR = do case btnResult of (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" - (FormSuccess CrashApp) -> addMessage Error "Crash Button Ratio 0 betätigt" >> error ("Crash Button" <> (show $ 1 % 0)) + (FormSuccess CrashApp) -> addMessage Error "Crash Button Ratio 0 betätigt" >> error ("Crash Button" <> show (1 % 0)) FormMissing -> return () _other -> addMessage Warning "KEIN Knopf erkannt" From ebb81e0c54f9a8d3b6d27ce9d650d50b8bd8bcd2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 24 Apr 2023 16:42:57 +0000 Subject: [PATCH 15/56] refactor(avs): avs queries are automatically chunked --- src/Model/Types/Avs.hs | 6 ++++ src/Utils/Avs.hs | 68 +++++++++++++++++++----------------------- 2 files changed, 36 insertions(+), 38 deletions(-) diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index bd9aaa0e9..a12980ed6 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -197,6 +197,7 @@ discernAvsCardPersonalNo _ = Nothing newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int deriving (Eq, Ord, Generic) deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable, Binary) +-- TODO: consider using "makeWrapped ''AvsPersonId" instance E.SqlString AvsPersonId -- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API; instance FromJSON AvsPersonId where @@ -590,6 +591,7 @@ deriveJSON defaultOptions type AvsResponseStatus :: Type newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson) deriving (Eq, Ord, Show, Generic) +makeWrapped ''AvsResponseStatus deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -601,6 +603,7 @@ instance Semigroup AvsResponseStatus where newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) deriving (Eq, Ord, Show, Generic) +-- makeWrapped ''AvsResponsePerson deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -610,6 +613,7 @@ deriveJSON defaultOptions newtype AvsResponseContact = AvsResponseContact (Set AvsDataContact) deriving (Eq, Ord, Show, Generic) +makeWrapped ''AvsResponseContact deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True @@ -666,10 +670,12 @@ deriveJSON defaultOptions newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId) deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQueryStatus +makeWrapped ''AvsQueryStatus newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQueryContact +makeWrapped ''AvsQueryContact newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently deriving (Eq, Ord, Show, Generic) diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 00580b26a..abe528279 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -13,10 +13,10 @@ import qualified Data.Text as Text import Servant import Servant.Client -#ifdef DEVELOPMENT -#else +-- #ifdef DEVELOPMENT +-- #else import Servant.Client.Core (requestPath) -#endif +-- #endif import Model.Types.Avs @@ -34,8 +34,8 @@ type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQueryS avsMaxSetLicenceAtOnce :: Int avsMaxSetLicenceAtOnce = 90 -- maximum input set size for avsQuerySetLicences as enforced by AVS -avsMaxGetStatusAtOnce :: Int -avsMaxGetStatusAtOnce = 900 -- maximum input set size for avsQueryStatus as enforced by AVS +avsMaxQueryAtOnce :: Int +avsMaxQueryAtOnce = 900 -- maximum input set size for avsQueryStatus as enforced by AVS avsApi :: Proxy AVS @@ -68,20 +68,20 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery -#ifdef DEVELOPMENT -mkAvsQuery _ _ _ = AvsQuery - { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty - , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty - , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) - , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty - , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty - } -#else +-- #ifdef DEVELOPMENT +-- mkAvsQuery _ _ _ = AvsQuery +-- { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty +-- , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty +-- , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) +-- , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty +-- , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty +-- } +-- #else mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery - { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv - , avsQueryStatus = \q -> liftIO $ runClientM (splitQueryStatus q) cliEnv - , avsQueryContact = \q -> liftIO $ runClientM (rawQueryContact q) cliEnv - , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv + { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv + , avsQueryStatus = \q -> liftIO $ runClientM (splitQuery rawQueryStatus q) cliEnv + , avsQueryContact = \q -> liftIO $ runClientM (splitQuery rawQueryContact q) cliEnv + , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- TODO: currently uses setLicencesAvs for splitting to ensure return of correctly set licences -- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv , avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv } @@ -96,26 +96,18 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database! catch404toEmpty other = other - -- TODO: make a generic implementation for this - splitQueryStatus :: AvsQueryStatus -> ClientM AvsResponseStatus - splitQueryStatus q@(AvsQueryStatus avids) - | Set.size avids <= avsMaxGetStatusAtOnce = rawQueryStatus q - | otherwise = do - let (avid_1,avid_2) = Set.splitAt avsMaxGetStatusAtOnce avids - res1 <- rawQueryStatus (AvsQueryStatus avid_1) - res2 <- splitQueryStatus (AvsQueryStatus avid_2) - return $ res1 <> res2 - - -- splitQuery :: (a -> Set b) -> (Set b -> a) -> (a -> ClientM c) -> a -> ClientM c - -- splitQuery toSet fromSet rawQuery q - -- | Set.size (toSet q) <= avsMaxGetStatusAtOnce = rawQueryStatus q - -- | otherwise = do - -- let (fromSet -> avid_1,fromSet -> avid_2) = Set.splitAt avsMaxGetStatusAtOnce (toSet q) - -- res1 <- rawQuery avid_1 - -- res2 <- splitQuery toSet fromSet rawQuery avid_2 - -- return $ fromSet (toSet res1 <> toSet res2) - -#endif + splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Semigroup (Unwrapped c)) + => (a -> ClientM c) -> a -> ClientM c + splitQuery rawQuery q + | Set.size s <= avsMaxQueryAtOnce = rawQuery q + | otherwise = do + let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s + res1 <- rawQuery $ view _Unwrapped' avsid1 + res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2 + return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped') + where + s = view _Wrapped' q +-- #endif ----------------------- -- Utility Functions -- From 76fb44d898f684396fd98fe55ff8e64a7980b704 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Apr 2023 09:48:45 +0000 Subject: [PATCH 16/56] chore(users): keep filters after table action --- src/Handler/Users.hs | 18 +++++++++--------- src/Handler/Utils.hs | 19 +++++++++++++++++++ src/Handler/Utils/Table/Pagination.hs | 2 +- src/Utils/Form.hs | 3 ++- templates/widgets/form/form.hamlet | 2 +- 5 files changed, 32 insertions(+), 12 deletions(-) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 2c68d028a..3ae8c8885 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -334,7 +334,7 @@ postUsersR = do , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtParams = DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute UsersR + , dbParamsFormAction = Nothing -- Just $ SomeRoute (UsersR, [("users-user-company","fraport")]) , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional @@ -351,21 +351,21 @@ postUsersR = do , dbtExtraReps = [] } + $logInfoS "UsersFormResult" $ tshow usersRes formResult usersRes $ \case (act, usersSet) - | Set.null usersSet && isNotSetSupervisor act -> do - addMessageI Info MsgActionNoUsersSelected - redirect UsersR + | Set.null usersSet && isNotSetSupervisor act -> + addMessageI Info MsgActionNoUsersSelected (UserLdapSyncData, userSet) -> do runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid - addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet - redirect UsersR + addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet + redirectKeepGetParams UsersR (UserHijack, Set.minView -> Just (uid, _)) -> hijackUser uid >>= sendResponse (UserRemoveSupervisorData, userSet) -> do runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet - redirect UsersR + redirectKeepGetParams UsersR (act, usersSet) | isActionSupervisor act -> do avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act @@ -382,8 +382,8 @@ postUsersR = do if nrSuperNotFound > 0 then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound) - redirect UsersR - _other -> error "Should not be possible" + redirectKeepGetParams UsersR + _other -> addMessageI Warning MsgInvalidInput ((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 1ff03ffde..f7a43dd6a 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -137,3 +137,22 @@ redirectAlternatives = go Just xs' -> over _1 (x :) $ nunsnoc xs' nsnoc [] x = x :| [] nsnoc (x' : xs) x = x' :| (xs ++ [x]) + +-- | redirect to currentRoute, if Just otherwise to given default +reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a +reload r = getCurrentRoute >>= redirect . fromMaybe r + +-- | like `reload`, preserving all GET parameters +reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a +reloadKeepGetParams r = liftHandler $ do + getps <- reqGetParams <$> getRequest + route <- fromMaybe r <$> getCurrentRoute + -- addMessage Info $ toHtml (show getps) -- DEBUG ONLY + -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")]) + redirect (route, getps) + +-- | redirect preserving all GET parameters +redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a +redirectKeepGetParams route = liftHandler $ do + getps <- reqGetParams <$> getRequest + redirect (route, getps) \ No newline at end of file diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 10b90e28f..076b1ac29 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -964,7 +964,7 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En instance Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where def = DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Nothing + , dbParamsFormAction = Nothing -- Recall: Nothing preserves GET Parameters , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = \_ -> return (pure (), mempty) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 9ad82b29f..c5f8ef383 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -307,7 +307,7 @@ data FormIdentifier | FIDAvsQueryLicence | FIDAvsSetLicence | FIDBtnAvsImportUnknown - | FIDBtnAvsRevokeUnknown + | FIDBtnAvsRevokeUnknown deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where @@ -1089,6 +1089,7 @@ wrapForm' :: Button site button => button -> WidgetT site IO () -> FormSettings wrapForm' btn formWidget FormSettings{..} = do formId <- maybe newIdent (return . toPathPiece) formAnchor formActionUrl <- traverse toTextUrl formAction + let hasAction = isJust formActionUrl $(widgetFile "widgets/form/form") diff --git a/templates/widgets/form/form.hamlet b/templates/widgets/form/form.hamlet index 7d4a7901f..371a7c701 100644 --- a/templates/widgets/form/form.hamlet +++ b/templates/widgets/form/form.hamlet @@ -5,7 +5,7 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later $# Wrapper for all kinds of forms -
+ $# Distinguish different falvours of submit button layouts here: $case formSubmit $of FormNoSubmit From 014d479df8f36515915bc7991bb97bad24dcbef9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Apr 2023 09:56:18 +0000 Subject: [PATCH 17/56] fix(users): prevent accidental user hijacking --- src/Handler/Users.hs | 4 ++-- src/Utils/Form.hs | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 3ae8c8885..1e20bdde1 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -45,7 +45,7 @@ import Auth.Dummy (apDummy) hijackUserForm :: Form () -hijackUserForm csrf = do +hijackUserForm = identifyForm FIDHijackUser $ \csrf -> do (btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView]) @@ -351,7 +351,7 @@ postUsersR = do , dbtExtraReps = [] } - $logInfoS "UsersFormResult" $ tshow usersRes + -- $logInfoS "UsersFormResult" $ tshow usersRes formResult usersRes $ \case (act, usersSet) | Set.null usersSet && isNotSetSupervisor act -> diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index c5f8ef383..1cee75678 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -308,6 +308,7 @@ data FormIdentifier | FIDAvsSetLicence | FIDBtnAvsImportUnknown | FIDBtnAvsRevokeUnknown + | FIDHijackUser deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where From 32b1074dcaf949d8d9b9a50ec648820a1aadb4db Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Apr 2023 10:41:48 +0000 Subject: [PATCH 18/56] chore(actions): keep filters for table actions on LMS, Qualifications and PrintCenter --- .../uniworx/categories/term/de-de-formal.msg | 4 ++-- messages/uniworx/utils/utils/de-de-formal.msg | 6 ++++-- messages/uniworx/utils/utils/en-eu.msg | 6 ++++-- src/Handler/LMS.hs | 17 +++++++---------- src/Handler/PrintCenter.hs | 10 ++++------ src/Handler/Qualification.hs | 18 ++++++++---------- src/Handler/Users.hs | 4 ++-- src/Handler/Utils.hs | 2 +- src/Utils/Form.hs | 2 +- 9 files changed, 33 insertions(+), 36 deletions(-) diff --git a/messages/uniworx/categories/term/de-de-formal.msg b/messages/uniworx/categories/term/de-de-formal.msg index 8a93e5698..80555c631 100644 --- a/messages/uniworx/categories/term/de-de-formal.msg +++ b/messages/uniworx/categories/term/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost ,Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -14,7 +14,7 @@ TermEnd: Ende Kursperiode LectureStart: Beginn Kurse TermEdited tid@TermId: Semester #{tid} erfolgreich editiert. TermNewTitle: Semester editieren/anlegen. -InvalidInput: Eingaben bitte korrigieren. +InvalidInput: Ungültige Eingabe, bitte korrigieren. Term !ident-ok: Semester TermPlaceholder: JJJJ TermStartDay: Erster Tag diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 3dfdcd670..1d5b9d184 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2023 Steffen Jost ,Gregor Kleen ,Sarah Vaupel ,Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -150,4 +150,6 @@ SheetGradingPassPoints': Bestehen nach Punkten SheetGradingPassBinary': Bestanden/Nicht bestanden SheetGradingPassAlways': Automatisch bestanden, sobald korrigiert SheetTypeNormal !ident-ok: Normal -SheetTypeBonus !ident-ok: Bonus \ No newline at end of file +SheetTypeBonus !ident-ok: Bonus + +InvalidFormAction: Keine Aktion ausgeführt wegen ungültigen Formulardaten \ No newline at end of file diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 8e551020c..9162d42f4 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2023 Sarah Vaupel ,Winnie Ros ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -150,4 +150,6 @@ SheetGradingPassPoints': Passing by points SheetGradingPassBinary': Pass/Fail SheetGradingPassAlways': Automatically passed when corrected SheetTypeNormal: Normal -SheetTypeBonus: Bonus \ No newline at end of file +SheetTypeBonus: Bonus + +InvalidFormAction: No action taken due to invalid form data \ No newline at end of file diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 8b3f3d9db..7ec9be91b 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2023 Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -365,16 +365,14 @@ mkLmsTable :: forall h p cols act act'. -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) -> DB (FormResult (act', Set UserId), Widget) mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do - now <- liftIO getCurrentTime - currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here - let - -- currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali) -- bad idea as seen + now <- liftIO getCurrentTime + let nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "qualification" - dbtSQLQuery q = lmsTableQuery qid q + dbtSQLQuery = lmsTableQuery qid dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjId @@ -472,7 +470,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional @@ -504,8 +502,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do - isAdmin <- hasReadAccessTo AdminR - currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler + isAdmin <- hasReadAccessTo AdminR ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do qent <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) @@ -613,7 +610,7 @@ postLmsR sid qsh = do when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal numExaminees when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected - redirect currentRoute + reloadKeepGetParams $ LmsR sid qsh let heading = citext2widget $ "LMS " <> qualificationName quali siteLayout heading $ do diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index c6faa651e..cd3beeec1 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -157,8 +157,7 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient return (printJob, recipient, sender, course, quali) mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget) -mkPJTable = do - currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here +mkPJTable = do let dbtSQLQuery = pjTableQuery dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) @@ -227,7 +226,7 @@ mkPJTable = do dbtExtraReps = [] dbtParams = DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional @@ -254,8 +253,7 @@ mkPJTable = do getPrintCenterR, postPrintCenterR :: Handler Html getPrintCenterR = postPrintCenterR -postPrintCenterR = do - currentRoute <- fromMaybe (error "printCenterR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler +postPrintCenterR = do (pjRes, pjTable) <- runDB mkPJTable formResult pjRes $ \case @@ -263,7 +261,7 @@ postPrintCenterR = do now <- liftIO getCurrentTime num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. pjIds] [PrintJobAcknowledged =. Just now] addMessageI Success $ MsgPrintJobAcknowledge num - redirect currentRoute + reloadKeepGetParams PrintCenterR siteLayoutMsg MsgMenuApc $ do setTitleI MsgMenuApc diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 242c3c355..11669a68c 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2023 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -294,8 +294,7 @@ mkQualificationTable :: -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do svs <- getSupervisees - now <- liftIO getCurrentTime - currentRoute <- fromMaybe (error "mkQualificationTable called from 404-handler") <$> liftHandler getCurrentRoute + now <- liftIO getCurrentTime let nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday @@ -303,7 +302,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do dbtIdent :: Text dbtIdent = "qualification" fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs - dbtSQLQuery q = qualificationTableQuery qid fltrSvs q + dbtSQLQuery = qualificationTableQuery qid fltrSvs dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjId -- FilteredPostId dbtColonnade = cols @@ -393,7 +392,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do dbtExtraReps = [] dbtParams = DBParamsForm { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional @@ -419,8 +418,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html getQualificationR = postQualificationR -postQualificationR sid qsh = do - currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler +postQualificationR sid qsh = do isAdmin <- hasReadAccessTo AdminR ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh @@ -476,7 +474,7 @@ postQualificationR sid qsh = do let msgKind = if upd > 0 then Success else Warning msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire addMessageI msgKind msgVal - redirect currentRoute + reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do now <- liftIO getCurrentTime let nowaday = utctDay now @@ -498,8 +496,8 @@ postQualificationR sid qsh = do | isNothing qubr -> MsgQualificationStatusUnblock | otherwise -> MsgQualificationStatusBlock addMessageI warnLevel $ fbmsg qsh oks nrq - redirect currentRoute - _ -> addMessageI Error MsgUnauthorized + reloadKeepGetParams $ QualificationR sid qsh + _ -> addMessageI Error MsgInvalidFormAction let heading = citext2widget $ qualificationName quali siteLayout heading $ do diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 1e20bdde1..6961ac1f9 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -383,7 +383,7 @@ postUsersR = do then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound) redirectKeepGetParams UsersR - _other -> addMessageI Warning MsgInvalidInput + _other -> addMessageI Error MsgInvalidFormAction ((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index f7a43dd6a..d13be8cee 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 1cee75678..1dfdc2703 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2023 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Wolfgang Witt -- -- SPDX-License-Identifier: AGPL-3.0-or-later From 0922723a85b97d51081484f4fa6a407b6451d0f7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Apr 2023 10:42:16 +0000 Subject: [PATCH 19/56] chore(avs): reactivate avs development dummy --- src/Utils/Avs.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index abe528279..7dfe7148c 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -13,10 +13,10 @@ import qualified Data.Text as Text import Servant import Servant.Client --- #ifdef DEVELOPMENT --- #else +#ifdef DEVELOPMENT +#else import Servant.Client.Core (requestPath) --- #endif +#endif import Model.Types.Avs @@ -68,15 +68,15 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery --- #ifdef DEVELOPMENT --- mkAvsQuery _ _ _ = AvsQuery --- { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty --- , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty --- , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) --- , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty --- , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty --- } --- #else +#ifdef DEVELOPMENT +mkAvsQuery _ _ _ = AvsQuery + { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty + , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty + , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) + , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty + , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty + } +#else mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv , avsQueryStatus = \q -> liftIO $ runClientM (splitQuery rawQueryStatus q) cliEnv @@ -107,7 +107,7 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped') where s = view _Wrapped' q --- #endif +#endif ----------------------- -- Utility Functions -- From 5fcc85c9a029ce5826ff93b9e14eefac892ca2eb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Apr 2023 13:10:19 +0000 Subject: [PATCH 20/56] refactor(login): clarify login fields --- messages/auth/campus/de.msg | 4 ++-- messages/auth/campus/en.msg | 4 ++-- messages/uniworx/categories/authorization/de-de-formal.msg | 6 +++--- messages/uniworx/categories/authorization/en-eu.msg | 6 +++--- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/messages/auth/campus/de.msg b/messages/auth/campus/de.msg index 8755ecf03..1812fdf28 100644 --- a/messages/auth/campus/de.msg +++ b/messages/auth/campus/de.msg @@ -2,7 +2,7 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later -CampusIdentPlaceholder: V.Nachname@fraport.de -CampusIdent: Fraport AG Kennung +CampusIdentPlaceholder: V.Nachname@fraport.de / E12345 +CampusIdent: Fraport Kennung CampusPassword: Passwort CampusPasswordPlaceholder: Passwort \ No newline at end of file diff --git a/messages/auth/campus/en.msg b/messages/auth/campus/en.msg index 55652d3fa..02ffd46fd 100644 --- a/messages/auth/campus/en.msg +++ b/messages/auth/campus/en.msg @@ -2,7 +2,7 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later -CampusIdentPlaceholder: F.Last@fraport.de -CampusIdent: Fraport AG account +CampusIdentPlaceholder: F.Last@fraport.de / E12345 +CampusIdent: Fraport account CampusPassword: Password CampusPasswordPlaceholder: Password \ No newline at end of file diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index e16240aa5..b7ee11560 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -96,9 +96,9 @@ TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei. ExamOccurrenceNoCapacity: Zu diesem Termin/Raum sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer:innen angemeldet. -LDAPLoginTitle: Fraport AG Login (Büko) -PWHashLoginTitle: FRADrive Login -PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden! +LDAPLoginTitle: Fraport Login für interne und externe Nutzer +PWHashLoginTitle: Spezieller Funktionsnutzer Login +PWHashLoginNote: Verwenden Sie dieses Formular nur, wenn Sie explizit dazu aufgefordert wurden. Alle anderen sollten das andere Login Formular verwenden! DummyLoginTitle: Development-Login InternalLdapError: Interner Fehler beim Fraport Büko-Login CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index d2ad99d62..59dad7860 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -97,9 +97,9 @@ TutorialNoCapacity: Tutorial has reached maximum capacity ExamOccurrenceNoCapacity: Occurrence/Room has reached maximum capacity CourseNotEmpty: There are currently no participants enrolled for this course. -LDAPLoginTitle: Fraport AG login (Büko) -PWHashLoginTitle: FRADrive login -PWHashLoginNote: Use this form if you have received special FRADrive credentials. Fraport AG employees should use the Büko login instead! +LDAPLoginTitle: Fraport login for intern and extern users +PWHashLoginTitle: Special function user login +PWHashLoginNote: Only use this login form if you have received special instructions to do so. All others should use the other login field. DummyLoginTitle: Development login InternalLdapError: Internal error during Fraport Büko login CampusUserInvalidIdent: Could not determine unique identification during Fraport Büko login From d973acf42b27645aa436dda389fed9411bace950 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 25 Apr 2023 14:43:50 +0000 Subject: [PATCH 21/56] chore(print): switch all letters to sans serif font --- templates/letter/din5008.latex | 3 ++- templates/letter/din5008with_pin.latex | 1 + templates/letter/plain_article.latex | 10 +++++++--- test/Database/Fill.hs | 2 +- 4 files changed, 11 insertions(+), 5 deletions(-) diff --git a/templates/letter/din5008.latex b/templates/letter/din5008.latex index c6c88f17e..0816d2ec5 100644 --- a/templates/letter/din5008.latex +++ b/templates/letter/din5008.latex @@ -66,7 +66,8 @@ $endif$ % if luatex or xetex \usepackage{fontspec} \setmonofont{DejaVu Sans Mono} -\fi +\fi +\renewcommand{\familydefault}{\sfdefault} $if(mathspec)$ \ifXeTeX diff --git a/templates/letter/din5008with_pin.latex b/templates/letter/din5008with_pin.latex index 22e3b0a0f..68047cc04 100644 --- a/templates/letter/din5008with_pin.latex +++ b/templates/letter/din5008with_pin.latex @@ -67,6 +67,7 @@ $endif$ \usepackage{fontspec} \setmonofont{DejaVu Sans Mono} \fi +\renewcommand{\familydefault}{\sfdefault} $if(mathspec)$ \ifXeTeX diff --git a/templates/letter/plain_article.latex b/templates/letter/plain_article.latex index e95489125..bdd9d7cd9 100644 --- a/templates/letter/plain_article.latex +++ b/templates/letter/plain_article.latex @@ -51,15 +51,19 @@ $endif$ \fi \ifPDFTeX + \usepackage{helvet} \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[utf8]{inputenc} - \usepackage{textcomp} % provide euro and other symbols - \usepackage{DejaVuSansMono} % better monofont + \usepackage{textcomp}% provide euro and other symbols + \usepackage{DejaVuSansMono}% better monofont + \renewcommand{\familydefault}{\sfdefault} \else % if luatex or xetex \usepackage{fontspec} + %\setmainfont{TeXGyreHeros}%could not install the package somehow tex-gyre in default.nix/shell.nix did not work + \setmainfont{DejaVu Sans} \setmonofont{DejaVu Sans Mono} - %\renewcommand{\familydefault}{\sfdefault} + \renewcommand{\familydefault}{\sfdefault} \fi $if(mathspec)$ diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index b5f4549ba..13c67c30c 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -932,7 +932,7 @@ fillDb = do

Benötigte Unterlagen