build(Makefile): load and use ci-images from tar file if present for frontend and backend

.babelrc.license

@@ -0,0 +1,3 @@
+SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
+
+SPDX-License-Identifier: AGPL-3.0-or-later

.eslintrc.json.license

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

.gitignore

@@ -2,12 +2,9 @@
 dist*
 develop
 node_modules/
-.npm/
+assets/icons
-.node_repl_history
+assets/favicons
-**/assets/icons
-**/assets/favicons
 bin/
-assets/fonts/
 *.hi
 *.o
 *.sqlite3
@@ -40,21 +37,22 @@ uniworx.nix
 .kateproject
 src/Handler/Assist.bak
 src/Handler/Course.SnapCustom.hs
+frontend/src/env.sass
 *.orig
 /instance
-backend/instance
 .stack-work-*
-.stack-work.lock
 .directory
 tags
 test.log
 *.dump-splices
+/.stack-work.lock
+/.npmrc
+/.npm/
 /config/manifest.json
 tunnel.log
-static
+/static
-well-known
+/well-known
-.well-known-cache
+/.well-known-cache
-manifest.json
 /.nix-well-known
 /**/tmp-*
 /testdata/bigAlloc_*.csv
@@ -68,4 +66,5 @@ manifest.json
 **/result-*
 .develop.cmd
 /.vscode
-backend/.ghc/ghci_history
+.ghc/ghci_history
+.azure-pipelines/images/*.tar

CHANGELOG.md

@@ -2,16 +2,6 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
-## [27.4.59-0.0.20+145-build-system-rewrite](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/27.4.59-0.0.19+145-build-system-rewrite...27.4.59-0.0.20+145-build-system-rewrite) (2025-03-19)
-
-## [27.4.59-0.0.19+145-build-system-rewrite](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/27.4.59-0.0.18+145-build-system-rewrite...27.4.59-0.0.19+145-build-system-rewrite) (2025-03-17)
-
-## [27.4.59-0.0.18+145-build-system-rewrite](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-g0.0.17...27.4.59-0.0.18+145-build-system-rewrite) (2025-03-17)
-
-### Bug Fixes
-
-* **static:** fix addStaticContent by using memcached again to supply static files ([570cfc2](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive/commit/570cfc238bdccd3438124f96290b9272c8e82f0f))
-
 ## [v27.4.59-test-g0.0.17](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-f0.0.17...v27.4.59-test-g0.0.17) (2025-02-18)
 
 ## [v27.4.59-test-f0.0.17](https://fraport@dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive//compare/v27.4.59-test-g0.0.16...v27.4.59-test-f0.0.17) (2025-02-17)

Makefile

@@ -1,59 +1,96 @@
+
 export SHELL=bash
 
-export CLEAN_DEPENDENCIES ?= false
+# MAKE=make -f Makefile-loggingsymbols
-export CLEAN_IMAGES ?= false
+# MAKE=make -d
 
-export ENTRYPOINT ?= bash
+# System information
+export CPU_CORES = $(shell cat /proc/cpuinfo | grep '^processor' | wc -l)
+
+export CONTAINER_COMMAND ?= podman
+export CONTAINER_BGRUN ?= $(CONTAINER_COMMAND) run -dit --network=host --replace
+export CONTAINER_FGRUN ?= $(CONTAINER_COMMAND) run -it --network=host --replace
+
+export IMAGE_REGISTRY = docker.io
+export MEMCACHED_IMAGE = $(IMAGE_REGISTRY)/memcached:latest
+export MINIO_IMAGE = $(IMAGE_REGISTRY)/minio/minio:latest
+export MAILDEV_IMAGE = $(IMAGE_REGISTRY)/maildev/maildev:latest # TODO: needs different port than 1025 to avoid conflicts
+
+export CI_IMAGE_DIR ?= ./.azure-pipelines/images
+export CI_IMAGE_REPO = devfra.azurecr.io/de.fraport.fradrive.build
+export PREFER_CI_IMAGES ?= true
+
+export IN_CONTAINER ?= false
+export IN_CI ?= false
+export CONTAINER_FILE
+export CONTAINER_IDENT
+export CF_PREFIX
+export DEVELOP
+export CONTAINER_ATTACHED
+export CONTAINER_INIT
+export CONTAINER_CLEANUP
+export PROJECT_DIR=/fradrive
+
+export SERVICE
+export SERVICE_VARIANT ?= $(SERVICE)
+export JOB
+export IMAGE
+export IMAGE_FALLBACK
+export SET_IMAGE
+export ENTRYPOINT
+export EXEC_OPTS
+export IMAGE_PULL_POLICY?=missing
+
+export STACK_CORES = $(shell echo $(($(CPU_CORES)/2)))
+export BASE_PORTS
+export UNIWORXDB_OPTS ?= -cf
+export PROD ?= false
 export SRC
 
+ifneq ($(PROD),true)
+  export --DEVELOPMENT=--flag uniworx:dev
+endif
+
+export DATE := $(shell date +'%Y-%m-%dT%H-%M-%S')
+
+export CURR_DEV = $(shell cat develop/.current 2>/dev/null)
+export SET_DEVELOP = $(eval DEVELOP=develop/$$(CURR_DEV))
+export NEW_DEVELOP = $(eval DEVELOP=develop/$$(DATE))
+
+
 .PHONY: help
 # HELP: print out this help message
 help:
-	docker compose run help
+	@if [ -z "$$(which perl 2>/dev/null)" ] ; then \
+	  $(CONTAINER_FGRUN) .:/mnt 'debian:12.5' '/mnt/utils/makehelp.pl' '/mnt/Makefile' ; \
+	else \
+	  utils/makehelp.pl Makefile ; \
+	fi
 
 .PHONY: clean
-# HELP: clean compilation caches
+# HELP: stop all running containers and remove all compilation results in the directory (but leave images including dependencies unharmed)
 clean:
-	$(MAKE) clean-frontend CLEAN_DEPENDENCIES=$(CLEAN_DEPENDENCIES) CLEAN_IMAGES=$(CLEAN_IMAGES) 
+	rm -rf develop
-	$(MAKE) clean-backend CLEAN_DEPENDENCIES=$(CLEAN_DEPENDENCIES) CLEAN_IMAGES=$(CLEAN_IMAGES)
+	-rm -rf node_modules .npm .cache assets/icons assets/favicons static well-known config/manifest.json frontend/src/env.sass
+	-rm -rf .stack-work .stack-work.lock
+	-rm -rf bin .Dockerfile develop
+	-$(CONTAINER_COMMAND) container prune --force
+.PHONY: clean-images
+# 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
 .PHONY: clean-all
-# HELP: clean everything, including dependency and image caches
+# HELP: like clean but with full container, image, and volume prune
-clean-all: CLEAN_DEPENDENCIES = true
+clean-all: clean-images
-clean-all: CLEAN_IMAGES = true
+	-rm -rf .stack
-clean-all: clean ;
 
-.PHONY: clean-%
-# HELP(clean-$SERVICE): invalidate caches for a given service. Supported services: frontend, backend.
-clean-%:
-	$(MAKE) stop-$*
-	@$(MAKE) -- --clean-$*
-	@echo "Cleaned $* build files and binaries."
-ifeq ("$(CLEAN_DEPENDENCIES)", "true")
-	@$(MAKE) -- --clean-$*-deps
-	@echo "Cleaned $* dependencies."
-endif
-ifeq ("$(CLEAN_IMAGES)", "true")
-	$(MAKE) kill-$*
-	docker compose rm --force --volumes
-	docker compose down --rmi 'all' --volumes
-	@echo "Cleaned $* image."
-endif
---clean-frontend:
-	-rm -rf assets/icons assets/favicons
-	-rm -rf static well-known
---clean-frontend-deps:
-	-rm -rf frontend/node_modules
-	-rm -rf frontend/.npm
---clean-backend:
-	-rm -rf backend/.stack-work
-	-rm -rf bin/
---clean-backend-deps:
-	-rf -rf backend/.stack
-
-
-# TODO: only release when build and tests are passing!!!
 .PHONY: release
 # HELP: create, commit and push a new release
+# TODO: only release when build and tests are passing!!!
 release:
 	VERSION=`./utils/version.pl -changelog CHANGELOG.md -v` ; \
 	git add CHANGELOG.md ; \
@@ -64,60 +101,368 @@ release:
 
 .PHONY: compile
 # HELP: perform full compilation (frontend and backend)
-compile: compile-frontend compile-backend ;
+compile:
-.PHONY: compile-%
+	$(MAKE) compile-frontend
-# HELP(compile-$SERVICE): compile a given service once
+	$(MAKE) compile-backend
-compile-%:
-	docker compose run --remove-orphans --build --no-deps $* make compile
 
 .PHONY: start
 # HELP: start complete development environment with a fresh test database
-start: start-postgres start-maildev start-memcached start-minio start-backend
+start:
-	docker compose exec backend make start
+	$(MAKE) start-postgres
+	$(MAKE) start-memcached
+	$(MAKE) start-minio
+	$(MAKE) compile-frontend
+	$(MAKE) compile-uniworxdb
+	$(MAKE) start-backend
+
+.PHONY: %-backend
+%-backend: SERVICE=backend
+%-backend: SERVICE_VARIANT=backend
+ifeq ($(PREFER_CI_IMAGES),true)
+  %-backend: IMAGE=$(CI_IMAGE_REPO)/backend
+  %-backend: IMAGE_FALLBACK=localhost/fradrive/backend
+else
+  %-backend: IMAGE=localhost/fradrive/backend
+endif
+%-backend: IMAGE_PULL_POLICY=never
+%-backend: BASE_PORTS = "DEV_PORT_HTTP=3000" "DEV_PORT_HTTPS=3443"
+
+.PHONY: %-uniworxdb
+%-uniworxdb: SERVICE=backend
+%-uniworxdb: SERVICE_VARIANT=uniworxdb
+ifeq ($(PREFER_CI_IMAGES),true)
+  %-uniworxdb: IMAGE=$(CI_IMAGE_REPO)/backend
+  %-uniworxdb: IMAGE_FALLBACK=localhost/fradrive/backend
+else
+  %-uniworxdb: IMAGE=localhost/fradrive/backend
+endif
+%-uniworxdb: IMAGE_PULL_POLICY=never
+
+.PHONY: %-ghci
+%-ghci: SERVICE=backend
+%-ghci: SERVICE_VARIANT=ghci
+ifeq ($(PREFER_CI_IMAGES),true)
+  %-ghci: IMAGE=$(CI_IMAGE_REPO)/backend
+  %-ghci: IMAGE_FALLBACK=localhost/fradrive/backend
+else
+  %-ghci: IMAGE=localhost/fradrive/backend
+endif
+%-ghci: IMAGE_PULL_POLICY=never
+
+.PHONY: %-hoogle
+%-hoogle: SERVICE=backend
+%-hoogle: SERVICE_VARIANT=hoogle
+%-hoogle: BASE_PORTS = "HOOGLE_PORT=8081"
+ifeq ($(PREFER_CI_IMAGES),true)
+  %-hoogle: IMAGE=$(CI_IMAGE_REPO)/backend
+  %-hoogle: IMAGE_FALLBACK=localhost/fradrive/backend
+else
+  %-hoogle: IMAGE=localhost/fradrive/backend
+endif
+%-hoogle: IMAGE_PULL_POLICY=never
+--start-hoogle:
+	HOOGLE_PORT=`cat $(CONTAINER_FILE) | grep 'HOOGLE_PORT=' | sed 's/HOOGLE_PORT=//'` ; \
+	stack $(STACK_CORES) hoogle -- server --local --port $${HOOGLE_PORT}
+
+.PHONY: %-frontend
+%-frontend: SERVICE=frontend
+%-frontend: SERVICE_VARIANT=frontend
+ifeq ($(PREFER_CI_IMAGES),true)
+  %-frontend: IMAGE=$(CI_IMAGE_REPO)/frontend
+  %-frontend: IMAGE_FALLBACK=localhost/fradrive/frontend
+else
+  %-frontend: IMAGE=localhost/fradrive/frontend
+endif
+%-frontend: IMAGE_PULL_POLICY=never
+
+.PHONY: %-postgres
+%-postgres: SERVICE=postgres
+%-postgres: SERVICE_VARIANT=postgres
+%-postgres: BASE_PORTS = "PGPORT=5432"
+# TODO: support ci-postgres images?
+%-postgres: IMAGE=localhost/fradrive/postgres
+
+.PHONY: %-memcached
+%-memcached: SERVICE=memcached
+%-memcached: SERVICE_VARIANT=memcached
+# TODO: support ci-memcached images?
+%-memcached: SET_IMAGE=$$(MEMCACHED_IMAGE) --port=`cat $$(CONTAINER_FILE) | grep 'MEMCACHED_PORT=' | sed 's/MEMCACHED_PORT=//'`
+%-memcached: BASE_PORTS = "MEMCACHED_PORT=11211"
+
+.PHONY: %-minio
+%-minio: SERVICE=minio
+%-minio: SERVICE_VARIANT=minio
+# TODO: support ci-minio images?
+%-minio: SET_IMAGE=$$(MINIO_IMAGE) -- server `mktemp` --address=:`cat $$(CONTAINER_FILE) | grep 'UPLOAD_S3_PORT=' | sed 's/UPLOAD_S3_PORT=//'`
+%-minio: BASE_PORTS = "UPLOAD_S3_PORT=9000"
+
 .PHONY: start-%
-# HELP(start-$SERVICE): start a given service
+start-%: JOB=start
-start-%:
+start-%: CF_PREFIX = start-
-	docker compose up -d --build $*
+start-%: CONTAINER_ATTACHED = false
+start-%: --act ;
+
+.PHONY: compile-%
+compile-%: JOB=compile
+compile-%: CF_PREFIX = compile-
+compile-%: CONTAINER_ATTACHED = true
+compile-%: --act ;
+
+.PHONY: dependencies-%
+dependencies-%: JOB=dependencies
+dependencies-%: CF_PREFIX = dependencies-
+dependencies-%: CONTAINER_ATTACHED = true
+dependencies-%: --act ;
+
+.PHONY: test-%
+test-%: JOB=test
+test-%: CF_PREFIX = test-
+test-%: CONTAINER_ATTACHED = true
+test-%: --act ;
+
+.PHONY: lint-%
+lint-%: JOB=lint
+lint-%: CF_PREFIX = lint-
+lint-%: CONTAINER_ATTACHED = true
+lint-%: --act ;
 
 .PHONY: shell-%
-# HELP(shell-$SERVICE): launch a (bash) shell inside a given service
+# HELP(shell-$SERVICE): launch (bash) shell inside a new $SERVICE container
-shell-%:
+shell-%: JOB=shell
-	docker compose run --build --no-deps --entrypoint="$(ENTRYPOINT)" $*
+shell-%: CF_PREFIX=shell-
+shell-%: CONTAINER_ATTACHED=true
+shell-%: --act ;
 .PHONY: ghci
-# HELP: launch ghci instance. Use in combination with SRC to specify the modules to be loaded by ghci: make ghci SRC=src/SomeModule.hs
+# HELP(ghci): launch new backend instance and enter interactive ghci shell
-ghci: ENTRYPOINT=stack ghci $(SRC)
+ghci: shell-ghci;
-ghci: shell-backend ;
 
-.PHONY: stop
+--act: --develop_containerized;
-# HELP: stop all services
+
-stop:
+--develop_%: PORTS = $(foreach PORT,$(BASE_PORTS),$(shell utils/next_free_port.pl $(PORT)))
-	docker compose down
+--develop_%: --ensure-develop
-.PHONY: stop-%
+	DEVELOP=develop/`cat develop/.current` ; \
-# HELP(stop-$SERVICE): stop a given service
+	CONTAINER_IDENT=$(CF_PREFIX)$(SERVICE_VARIANT) ; \
-stop-%:
+	CONTAINER_FILE=$${DEVELOP}/$${CONTAINER_IDENT} ; \
-	docker compose down $*
+	if [[ -e $${CONTAINER_FILE} ]]; then \
-.PHONY: kill-%
+	  >&2 echo "Another $* service is already running! Use \"make new-develop\" to start a new develop instance despite currently running services." ; \
-# HELP(kill-$SERVICE): kill a given service the hard way. Use this if the servive does not respond to stop.
+	  exit 1 ; \
-kill-%:
+	fi ; \
-	docker compose kill $*
+	echo "$(PORTS)" | sed 's/ /\n/g' > $${CONTAINER_FILE} ; \
+	$(MAKE) -- --$* CONTAINER_FILE=$${CONTAINER_FILE} CONTAINER_IDENT=$${CONTAINER_IDENT} JOB=$(JOB)
+
+.PHONY: rebuild-%
+# HELP(rebuild-{backend,frontend,database,memcached,minio}): force-reload a given ci image, or (if not present) force-rebuild a given container image
+rebuild-%:
+	$(MAKE) -- --image-build SERVICE=$* NO_CACHE=--no-cache
+--image-build:
+ifeq "$(IMAGE)" "$(CI_IMAGE_REPO)/$(SERVICE)"
+	$(CONTAINER_COMMAND) load --input="$(CI_IMAGE_DIR)/$(SERVICE).tar"
+else ifeq "$(IMAGE)" "localhost/fradrive/$(SERVICE)"
+	rm -f .Dockerfile
+	ln -s docker/$(SERVICE)/Dockerfile .Dockerfile
+	PROJECT_DIR=/fradrive; \
+	if [ "$(IN_CONTAINER)" == "false" ] ; then \
+	  $(CONTAINER_COMMAND) build $(NO_CACHE) \
+	    -v $(PWD):$${PROJECT_DIR}:rw \
+		--build-arg PROJECT_DIR=$${PROJECT_DIR} \
+	    --env IN_CONTAINER=true \
+		--env JOB=$(JOB) \
+		--tag fradrive/$(SERVICE) \
+		--pull=never \
+		--file $(PWD)/.Dockerfile ; \
+	fi
+else
+	:
+endif
+
+--containerized: --image-build
+	DEVELOP=`cat develop/.current` ; \
+	./utils/watchcontainerrun.sh "$(CONTAINER_COMMAND)" "$(CONTAINER_FILE)" "$(CONTAINER_INIT)" "$(CONTAINER_CLEANUP)" & \
+	CONTAINER_NAME=fradrive.$(CURR_DEV).$(CONTAINER_IDENT) ; \
+	if ! [ -z "$(SET_IMAGE)" ] ; \
+	  then \
+	    IMAGE="$(SET_IMAGE)" ; \
+	  else \
+	    IMAGE=$(IMAGE) ; \
+	fi ; \
+	CONTAINER_ID=`$(CONTAINER_BGRUN) \
+	  -v $(PWD):$(PROJECT_DIR):rw \
+	  --pull=$(IMAGE_PULL_POLICY) \
+	  --env IN_CONTAINER=true \
+	  --env CONTAINER_FILE=$(CONTAINER_FILE) \
+	  --env CONTAINER_NAME=$${CONTAINER_NAME} \
+	  --env JOB=$(JOB) \
+	  --env SRC=$(SRC) \
+	  --name $${CONTAINER_NAME} \
+	  $${IMAGE} \
+	  make -- --$(JOB)-$(SERVICE_VARIANT) IN_CONTAINER=true \
+	` ; \
+	printf "CONTAINER_ID=$${CONTAINER_ID}" >> "$(CONTAINER_FILE)" ; \
+	if [[ "true" == "$(CONTAINER_ATTACHED)" ]] ; then \
+	  $(CONTAINER_COMMAND) attach $${CONTAINER_ID} || : ; \
+	fi
+
+# For Reverse Proxy Problem see: https://groups.google.com/g/yesodweb/c/2EO53kSOuy0/m/Lw6tq2VYat4J
+# HELP(start-backend): start development instance
+--start-backend:
+	export YESOD_IP_FROM_HEADER=true; \
+	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 PORT=$${PORT:-$${DEV_PORT_HTTP}} ; \
+	export DETAILED_LOGGING=$${DETAILED_LOGGING:-true} ; \
+	export LOG_ALL=$${LOG_ALL:-false} ; \
+	export LOGLEVEL=$${LOGLEVEL:-info} ; \
+	export DUMMY_LOGIN=$${DUMMY_LOGIN:-true} ; \
+	export SERVER_SESSION_ACID_FALLBACK=$${SERVER_SESSION_ACID_FALLBACK:-true} ; \
+	export SERVER_SESSION_COOKIES_SECURE=$${SERVER_SESSION_COOKIES_SECURE:-false} ; \
+	export COOKIES_SECURE=$${COOKIES_SECURE:-false} ; \
+	export ALLOW_DEPRECATED=$${ALLOW_DEPRECATED:-true} ; \
+	export ENCRYPT_ERRORS=$${ENCRYPT_ERRORS:-false} ; \
+	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}"
+# 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
+# HELP(dependencies-backend): (re-)build backend dependencies
+--dependencies-backend: #uniworx.cabal
+	chown -R `id -un`:`id -gn` "$(PROJECT_DIR)"; \
+	stack build -j2 --only-dependencies
+# HELP(lint-backend): lint backend
+--lint-backend:
+	stack build $(STACK_CORES) --test --fast --flag uniworx:library-only $(--DEVELOPMENT) uniworx:test:hlint
+# HELP(test-backend): test backend
+--test-backend:
+	stack build $(STACK_CORES) --test --coverage --fast --flag uniworx:library-only $(--DEVELOPMENT)
+# uniworx.cabal:
+# 	stack exec -- hpack --force
+
+# HELP(compile-frontend): compile frontend assets
+--compile-frontend: node_modules assets esbuild.config.mjs frontend/src/env.sass
+	npm run build
+--start-frontend: --compile-frontend;
+--dependencies-frontend: node_modules assets;
+node_modules: package.json package-lock.json
+	npm install --cache .npm --prefer-offline
+package-lock.json: package.json
+	npm install --cache .npm --prefer-offline
+assets: assets/favicons assets/icons;
+assets/favicons:
+	./utils/faviconize.pl assets/favicon.svg long assets/favicons
+assets/icons: node_modules assets/icons-src/fontawesome.json
+	./utils/renamer.pl node_modules/@fortawesome/fontawesome-free/svgs/solid assets/icons-src/fontawesome.json assets/icons/fradrive
+	./utils/renamer.pl node_modules/@fortawesome/fontawesome-free/svgs/regular assets/icons-src/fontawesome.json assets/icons/fradrive
+	-cp assets/icons-src/*.svg assets/icons/fradrive
+frontend/src/env.sass:
+	echo "\$$path: '$${PROJECT_DIR}'" > frontend/src/env.sass
+static: node_modules assets esbuild.config.mjs frontend/src/env.sass
+	npm run build
+well-known: static;
+--lint-frontend: --compile-frontend
+	npm run lint
+--test-frontend: --compile-frontend
+	npm run test
+
+# HELP(compile-uniworxdb): clear and fill database. requires running postgres instance (use "make start-postgres" to start one)
+# TODO (db-m-$MIGRATION-backend): apply migration (see src/Model/Migration/Definition.hs for list of available migrations)
+--compile-uniworxdb: --compile-backend
+	SERVER_SESSION_ACID_FALLBACK=${SERVER_SESSION_ACID_FALLBACK:-true} ; \
+	AVSPASS=${AVSPASS:-nopasswordset} ; \
+	./bin/uniworxdb $(UNIWORXDB_OPTS)
+
+# HELP(shell-ghci): enter ghci shell. Use "make ghci SRC=<MODULE_FILE.hs>" to load specific source modules."
+--shell-ghci:
+	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
+--shell-%:
+	/bin/bash
+
+# HELP(start-minio): start minio service
 
 .PHONY: status
-# HELP: print an overview of currently running services and their health
+# HELP: print develop status: running containers, used ports
 status:
-	docker compose ps
+	@./utils/develop-status.pl -a
-.PHONY: top
-# HELP: print an overview of the ressource usage of the currently running services
-top:
-	docker compose stats
-.PHONY: list-projects
-# HELP: list all currently running projects on this machine
-list-projects:
-	docker compose ls
 
 .PHONY: log-%
-# HELP(log-$SERVICE): follow the output of a given service. Service must be running.
+# HELP(log-$(JOB)-$(SERVICE)): inspect output of a given service. The service must be currently running When a service supports multiple running instances in one develop (i.e. backend), you need to specify the exact instance by its associated file (e.g. backend-1, backend-2, etc.), please check the contents of the develop/ directory for a list of running instances.
 log-%:
-	docker compose logs --follow --timestamps $*
+	DEVELOP=develop/`cat develop/.current` ; \
+	SEARCH_FILE="$${DEVELOP}/$*" ; \
+	if [[ ! -e "$${SEARCH_FILE}" ]] ; then \
+	  SEARCH_FILE="$${DEVELOP}/.exited.$*" ; \
+	fi ; \
+	if [[ -e "$${SEARCH_FILE}" ]] ; then \
+	  $(CONTAINER_COMMAND) logs --follow `cat "$${SEARCH_FILE}" | grep CONTAINER_ID= | sed 's/^CONTAINER_ID=//'` ; \
+	else \
+	  >&2 echo "Cannot show log: No develop file found for '$*'" ; \
+	  exit 1 ; \
+	fi
+
+.PHONY: enter
+# HELP: launch (bash) shell inside a currently running container. Use ./enter shell wrapper for more convenient usage, possibly with tab-completion in the future
+enter: --ensure-develop
+	$(MAKE) -- --enter
+
+.PHONY: psql
+# HELP: enter psql (postgresql) cli inside a currently running database container
+psql: ENTRYPOINT=/usr/bin/psql -d uniworx
+psql: EXEC_OPTS=--user postgres
+psql: --ensure-develop
+	$(MAKE) -- --enter CONTAINER_FILE=develop/`cat develop/.current`/start-postgres
+
+--enter:
+	CONTAINER_ID=`cat $(CONTAINER_FILE) | grep 'CONTAINER_ID=' | sed 's/CONTAINER_ID=//'` ; \
+	$(CONTAINER_COMMAND) exec -it $(EXEC_OPTS) $${CONTAINER_ID} $(if $(ENTRYPOINT),$(ENTRYPOINT),/bin/bash)
+
+.PHONY: stop
+# HELP: stop all currently running develop instances
+stop:
+	rm -rf develop
+.PHONY: stop-%
+# HELP(stop-SERVICE): stop all currently running develop instances of a given service (i.e. backend,frontend,uniworxdb,hoogle,postgres,...)
+# HELP(stop-JOB): stop all currently running develop instances of a given job (i.e. compile,start,test,lint)
+stop-compile: CF_PREFIX=compile-
+stop-start: CF_PREFIX=start-
+stop-test: CF_PREFIX=test-
+stop-lint: CF_PREFIX=lint-
+stop-%: --stop;
+--stop:
+	$(SET_DEVELOP)
+ifdef CF_PREFIX
+	rm -rf $(DEVELOP)/$(CF_PREFIX)*
+endif
+ifdef SERVICE_VARIANT
+	rm -rf $(DEVELOP)/*-$(SERVICE_VARIANT)
+endif
+
+.PHONY: new-develop
+# HELP: instantiate new development bundle, i.e. create new directory under develop/
+new-develop:
+	$(NEW_DEVELOP)
+	mkdir -p $(DEVELOP)
+	$(MAKE) develop/.current
+.PHONY: switch-develop
+# HELP: switch current develop instance to DEVELOP=...
+switch-develop:
+	if ! [ -e develop/$(DEVELOP) ]; then \
+	  echo "Specified develop $(DEVELOP) does not exist! Not switching." ; \
+	  exit 1 ; \
+	fi ; \
+	echo "$(DEVELOP)" > develop/.current
+--ensure-develop:
+	if ! [[ -e develop ]]; then \
+	  $(MAKE) new-develop; \
+	fi
+	$(MAKE) develop/.current
+	$(SET_DEVELOP)
+.PHONY: develop/.current
+develop/.current:
+	ls -1 develop | tail -n1 > develop/.current
 
 .PHONY: --%
 .SUFFIXES: # Delete all default suffixes

assets/icons-src/fontawesome.json

@@ -29,7 +29,6 @@
 "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",
@@ -77,13 +76,12 @@
 "submission-no-users": "user-slash",
 "reset": "arrow-rotate-left",
 "blocked": "ban",
-"certificate": "car-side",
+"certificate": "certificate",
 "print-center": "envelopes-bulk",
 "letter": "envelopes-bulk",
 "at": "at",
 "supervisor": "person",
 "supervisor-foreign": "person-rays",
-"superior": "user-tie",
 "waiting-for-user": "user-gear",
 "expired": "hourglass-end",
 "locked": "lock",
@@ -91,18 +89,9 @@
 "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",
-"placeholder": "notdef",
+"placeholder": "notdef"
-"reroute": "diamond-turn-right",
-"top": "award",
-"wildcard": "asterisk",
-"user-unknown": "user-slash",
-"user-badge": "id-badge",
-"glasses": "glasses",
-"missing": "question",
-"pin-protect": "key"
 }
 

backend/Dockerfile

@@ -1,40 +0,0 @@
-ARG FROM_IMG=docker.io/library/debian
-ARG FROM_TAG=12.5
-
-FROM ${FROM_IMG}:${FROM_TAG}
-
-ENV LANG=de_DE.UTF-8
-
-# basic dependencies
-RUN apt-get -y update && apt-get -y install git
-RUN apt-get -y update && apt-get -y install haskell-stack
-RUN apt-get -y update && apt-get -y install llvm
-RUN apt-get -y update && apt-get install -y --no-install-recommends locales locales-all
-
-# compile-time dependencies
-RUN apt-get -y update && apt-get install -y libpq-dev libsodium-dev
-RUN apt-get -y update && apt-get -y install g++ libghc-zlib-dev libpq-dev libsodium-dev pkg-config
-RUN apt-get -y update && DEBIAN_FRONTEND=noninteractive apt-get install -y --no-install-recommends tzdata
-
-# run-time dependencies for uniworx binary
-RUN apt-get -y update && apt-get -y install fonts-roboto
-# RUN apt-get -y update && apt-get -y install pdftk
-# RUN apt-get -y update && apt-get -y install \
-# texlive texlive-latex-recommended texlive-luatex texlive-plain-generic texlive-lang-german texlive-lang-english
-RUN apt-get -y update && apt-get -y install texlive
-# RUN ls /usr/local/texlive
-# RUN chown -hR root /usr/local/texlive/2018
-# RUN tlmgr init-usertree
-# RUN tlmgr option repository ftp://tug.org/historic/systems/texlive/2018/tlnet-final
-# RUN tlmgr update --self --all
-
-ARG PROJECT_DIR=/fradrive
-ENV PROJECT_DIR=${PROJECT_DIR}
-# RUN mkdir -p "${PROJECT_DIR}"; chmod -R 777 "${PROJECT_DIR}"
-WORKDIR ${PROJECT_DIR}
-ENV HOME=${PROJECT_DIR}
-ENV STACK_ROOT="${PROJECT_DIR}/.stack"
-
-ENV STACK_SRC=""
-ENV STACK_ENTRY="ghci ${STACK_SRC}"
-ENTRYPOINT stack ${STACK_ENTRY}

backend/Makefile

@@ -1,51 +0,0 @@
-export CPU_CORES = $(shell cat /proc/cpuinfo | grep '^processor' | wc -l)
-export STACK_CORES = $(shell echo $(($(CPU_CORES)/2)))
-
-ifeq ($(PROD),true)
-export --DEVELOPMENT=--flag uniworx:-dev
-else
-export --DEVELOPMENT=--flag uniworx:dev
-endif
-
-.PHONY: dependencies
-dependencies:
-	stack install hpack; stack install yesod-bin; \
-	stack build -j2 --only-dependencies
-
-.PHONY: compile
-compile: dependencies
-	stack build $(STACK_CORES) --fast --profile --library-profiling --executable-profiling --flag uniworx:-library-only $(--DEVELOPMENT) --local-bin-path $$(pwd)/bin --copy-bins
-
-.PHONY: lint
-lint:
-	stack build $(STACK_CORES) --test --fast --flag uniworx:library-only $(--DEVELOPMENT) uniworx:test:hlint
-
-.PHONY: test
-test:
-	stack build $(STACK_CORES) --test --coverage --fast --flag uniworx:library-only $(--DEVELOPMENT)
-
-# For Reverse Proxy Problem see: https://groups.google.com/g/yesodweb/c/2EO53kSOuy0/m/Lw6tq2VYat4J
-.PHONY: start
-start: dependencies
-	export YESOD_IP_FROM_HEADER=true; \
-	export DEV_PORT_HTTP=3000; \
-	export DEV_PORT_HTTPS=3443; \
-	export HOST=127.0.0.1 ; \
-	export PORT=$${PORT:-$${DEV_PORT_HTTP}} ; \
-	export DETAILED_LOGGING=$${DETAILED_LOGGING:-true} ; \
-	export LOG_ALL=$${LOG_ALL:-false} ; \
-	export LOGLEVEL=$${LOGLEVEL:-info} ; \
-	export DUMMY_LOGIN=$${DUMMY_LOGIN:-true} ; \
-	export SERVER_SESSION_ACID_FALLBACK=$${SERVER_SESSION_ACID_FALLBACK:-true} ; \
-	export SERVER_SESSION_COOKIES_SECURE=$${SERVER_SESSION_COOKIES_SECURE:-false} ; \
-	export COOKIES_SECURE=$${COOKIES_SECURE:-false} ; \
-	export ALLOW_DEPRECATED=$${ALLOW_DEPRECATED:-true} ; \
-	export ENCRYPT_ERRORS=$${ENCRYPT_ERRORS:-false} ; \
-	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}"
-
-.PHONY: clean
-clean:
-	rm -rf .stack-work .stack uniworx.cabal .ghc

backend/config/develop-settings.yml

@@ -1,32 +0,0 @@
-# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
-#
-# 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
-
-mail-reroute-to: 
-  name: "FRADrive-QA-Umleitungen"
-  email: "FRADrive-TEST-Umleitungen@fraport.de"
-
-# Enqueue at specified hour, a few minutes later
-job-lms-qualifications-enqueue-hour: 16
-job-lms-qualifications-dequeue-hour: 4
-
-# Using these setting kills the job-workers somehow
-# job-workers: 5
-# job-flush-interval: 600
-# job-stale-threshold: 3600
-# job-move-threshold: 60
-

backend/messages/uniworx/categories/avs/en-eu.msg

@@ -1,68 +0,0 @@
-# SPDX-FileCopyrightText: 2022-25 Steffen Jost <s.jost@fraport.de>
-#
-# SPDX-License-Identifier: AGPL-3.0-or-later
-AvsPersonInfo: AVS person info
-AvsPersonId: AVS person id
-AvsPersonNo: AVS person number
-AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
-AvsPersonNoMismatch: AVS person number has changed and was not yet updated in FRADrive
-AvsPersonNoDiffers: There are currently two differing AVS person numbers associated with this user. Please contact an administrator to resolve this.
-AvsCardNo: Card number
-AvsFirstName: First name
-AvsLastName: Last name
-AvsPrimaryCompany: Primary company
-AvsInternalPersonalNo: Personnel number (Fraport AG only)
-AvsVersionNo: Version number
-AvsQueryNeeded: AVS connection required.
-AvsQueryEmpty: At least one query field must be filled!
-AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
-AvsLicence: Driving Licence
-
-AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive
-BtnAvsRevokeUnknown: Revoke AVS driving licences for unknown persons immediately
-BtnAvsImportUnknown: Import AVS data for unknown persons
-AvsRevokeFor n@Int: Are you sure to immediately revoke all apron driving licences for #{n} unknown #{pluralENs n "driver"}?
-AvsImportIDs n m: AVS person data imported: #{show n}/#{show m}
-AvsImportAmbiguous n@Int: Import failed for #{show n} ambiguous AVS Ids
-AvsImportUnknowns n@Int: Import failed for #{show n} unknown AVS Ids
-AvsSetLicences alic n m: _{alic} set in AVS: #{show n}/#{show m}
-SetFraDriveLicences q@String n@Int: #{q} granted in FRADrive for #{show n} users
-RevokeFraDriveLicencesError alic@AvsLicence: Revoking licences _{alic} failed entirely
-RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} revoked in FRADrive for #{show n} drivers
-RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked
-RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details
-AvsCommunicationError: AVS interface returned an unexpected error.
-AvsCommunicationTimeout: AVS interface returned no response within timeout limit.
-LicenceTableChangeAvs: Change in AVS
-LicenceTableGrantFDrive: Grant in FRADrive
-LicenceTableRevokeFDrive: Revoke in FRADrive
-TableAvsActiveCards: Valid Cards
-TableAvsCardValid: Currently valid
-TableAvsCardIssueDate: Issued
-TableAvsCardValidTo: Valid to
-AvsCardAreas: Card areas
-AvsCardColor: Color
-AvsCardColorGreen: Green
-AvsCardColorBlue: Blue
-AvsCardColorRed: Red
-AvsCardColorYellow: Yellow
-LastAvsSynchronisation: Last AVS synchronisation
-LastAvsSyncedBefore: Last AVS synchronisation before
-LastAvsSynchError: Last AVS Error
-
-AvsInterfaceUnavailable: AVS interface was not configured correctly or does not respond
-AvsUserUnassociated user: AVS id unknown for user #{user}
-AvsUserUnknownByAvs api: AVS reports id #{tshow api} as unknown (or no longer known)
-AvsUserAmbiguous api: Multiple matching users found for #{tshow api}
-AvsStatusSearchEmpty: AVS returned no card information
-AvsPersonSearchEmpty: AVS search returned empty result
-AvsPersonSearchAmbiguous: AVS search returned more than one result
-AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason}
-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.
-AvsUpdateDayCheck: In addition, a background AVS update has been scheduled for all persons occrring within the day agenda (once per Day).
-
-AvsNoApronCard: No valid card granting apron access found
-AvsNoCompanyCard mcn@(Maybe CompanyName): No valid card for booking company #{maybeEmpty mcn ciOriginal} found

backend/messages/uniworx/categories/courses/material/en-eu.msg

@@ -1,38 +0,0 @@
-# SPDX-FileCopyrightText: 2022 Winnie Ros <winnie.ros@campus.lmu.de>
-#
-# SPDX-License-Identifier: AGPL-3.0-or-later
-
-MaterialList: Material
-MaterialName: Name
-MaterialType: Type
-MaterialTypePlaceholder: Slides, Code, Example, ...
-MaterialTypeSlides: Slides
-MaterialTypeCode: Code
-MaterialTypeExample: Example
-MaterialDescription: Description
-MaterialVisibleFrom: Visible to participants from
-MaterialVisibleFromTip: Never visible to participants if left empty; leaving the date empty is only sensible for unfinished course category material or when course category material should be provided only to sheet correctors
-MaterialVisibleFromEditWarning: This course category material has already been published and should not be edited. Doing so might confuse the participants.
-MaterialInvisible: This course category material is currently invisible to participants!
-MaterialFiles: Files
-MaterialHeading materialName: #{materialName}
-MaterialListHeading: Course category materials
-MaterialNewHeading: Publish new course category material
-MaterialNewTitle: New course category material
-MaterialEditHeading materialName: Edit course category material “#{materialName}”
-MaterialEditTitle materialName: Edit course category material “#{materialName}”
-MaterialSaveOk tid ssh csh materialName: Successfully saved “#{materialName}” for course category #{tid}-#{ssh}-#{csh}
-MaterialNameDup tid ssh csh materialName: Course category material with the name “#{materialName}” already exists for course category #{tid}-#{ssh}-#{csh}
-MaterialDeleteCaption: Do you really want to delete the course category material mentioned below?
-MaterialDelHasFiles count: including #{count} #{pluralEN count "file" "files"}
-MaterialIsVisible: Caution, this course category material has already been published.
-MaterialDeleted materialName: Successfully deleted course category material “#{materialName}”
-MaterialArchiveName tid ssh csh materialName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase materialName}
-MaterialVideo materialName: #{materialName} - Video
-MaterialVideoUnsupported: Your browser does not seem to support embedded video
-MaterialVideoDownload: Download
-MaterialFree: Course category material is publicly available.
-AccessibleSince: Accessible since
-VisibleFrom: Published
-FilterMaterialNameSearch !ident-ok: Name
-FilterMaterialTypeAndDescriptionSearch: Type/description

backend/messages/uniworx/categories/firm/en-eu.msg

@@ -1,97 +0,0 @@
-# SPDX-FileCopyrightText: 2023-25 Steffen Jost <s.jost@fraport.de>
-#
-# SPDX-License-Identifier: AGPL-3.0-or-later
-
-FirmSuperDefault: Default supervisor
-FirmSuperForeign: External supervisor
-FirmSuperIrregular: Irregular supervisor
-FirmAssociates: Company associated users
-FirmContact: Company Contact
-FirmEmail: General company email
-FirmAddress: Postal address
-FirmDefaultPreferenceInfo: Default setting for new company associates only
-FirmAction: Companywide action
-FirmActionInfo: Affects alle company associates under your supervision.
-FirmActNotify: Send message
-FirmActResetSupervision: Reset supervisors for all company associates
-FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
-FirmActRemoveSupers: Terminate all company related supervisionships?
-FirmActResetMutualSupervision: Supervisors supervise each other
-FirmActResetSupersKeepAll: Keep all
-FirmActResetSupersRemoveAps: Remove default supervisors only
-FirmActResetSupersRemoveAll: Remove all
-FirmActAddSupervisors: Add supervisors
-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: #{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
-FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
-FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only
-FirmUserActNotify: Send message
-FirmUserActResetSupervision: Reset supervisors to company default
-FirmUserActSetSupervisor: Change supervision
-FirmUserActChangeContact: Change contact data for selected company associates
-FirmUserActChangeDetails: Edit company association
-FirmUserActRemove: Delete company association
-FirmUserActMkSuper: Mark as company supervisor
-FirmUserActChangeDetailsResult n t: #{n}/#{t} #{pluralENs n "company association"} updated
-FirmUserActChangeResult n t: Notification settings changed for #{n}/#{t} company #{pluralENs n "associate"}
-FirmUserActRemoveResult uc: #{pluralENsN uc "Company association"} deleted. 
-FirmRemoveSupervision sup sub: #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "No supervision" (pluralENsN sub "supervision")} removed due to eliminated supervisees.
-FirmNewSupervisor: Appoint new individual supervisors
-FirmSetSupervisor: Add existing supervisors
-FirmSetSupersReport nusr nspr nrem: #{nspr} individual supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
-FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)}
-FirmSuperActNotify: Send message
-FirmSuperActSwitchSuper: Change default company supervisor
-FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individual supervisions. Additionally use reset action, if desired.
-FirmSuperActRMSuperDef: Remove default supervisor
-FirmSuperActRMSuperActive: Terminate active supervisions within this company?
-FirmsNotification: Send company notification e-mail
-FirmNotification fsh: Send e-mail to #{fsh}
-FirmsNotificationTitle: Company notification
-FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification
-FilterSupervisor: Has active supervisor
-FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh}
-FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh}
-FilterForeignSupervisor: Has company-external supervisors
-FilterIsForeignSupervisee: Supervisor for company external users
-FilterFirmExtern: External company
-FilterFirmExternTooltip: i.e. is a postal address registered within AVS?
-FilterFirmPrimary: Is primary company in FRADrive
-FilterHasQualification: Has company associates with currently valid qualification
-FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh}
-FirmSupervisorIndependent: Independent supervisors
-FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users
-NoCompanySelected: Select at least one company, please.
-TableIsDefaultSupervisor: Default supervisor
-TableSuperior: Superior
-TableIsDefaultReroute: Default reroute
-FormFieldPostal: Notification type
-FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor
-FormFieldPinPass: Protect sensitive PDF e-mail attachments by password?
-FormFieldPinPassRemove: Remove password protection for PDF e-mail attachments?
-FirmSupervisionKeyData: Supervision key data
-CompanyUserPriority: Company priority
-CompanyUserPriorityTip: Company priority is relative to other company associations for a user
-CompanyUserUseCompanyAddress: Use company postal address
-CompanyUserUseCompanyAddressTip: if and only if the postal address of the user is empty
-CompanyUserUseCompanyPostalError: Individual postal address must left empty for the company address to be used!
-CompanySupervisorCompanyMissing fsh: Receiver is not associated with #{fsh} given as reroute reason
-CompanySuperviseeCompanyMissing fsh: Supervisee is not associated with #{fsh} detailed as supervisionship reason
-FirmSupervisionRInfo: Shown are supervisionships where either supervisor or supervisee no longer belong to the company associated with the supervisionship.
-SupervisionViolationChoice: Company association missing for
-SupervisionViolationEither: anyone
-SupervisionViolationSupervisor: Supervisor
-SupervisionViolationClient: Supervisee
-SupervisionViolationBoth: both
-SupervisionsRemoved n m: #{n}/#{m} #{pluralENs n "Supervisionship"} removed.
-SupervisionsEdited n m: #{n}/#{m} #{pluralENs n "Supervisionship"} edited.
-ASChangeCompany: Change supervisionship annotations
-ASRemoveAssociation: Delete supervisionship
-FirmNameNotFound: No company found with this name/shorthand or AVS number. 
-FirmNameAmbiguous: Company name/shorthand or AVS number is amiguous.

backend/models/company.model

@@ -1,20 +0,0 @@
--- SPDX-FileCopyrightText: 2022-25 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
--- Description of companies associated with users
-
-Company  
-  name            CompanyName             -- == (CI Text) -- NOTE: Fraport department name may carry additional information; use the Shorthand with respect to UserCompanyDepartment
-  shorthand       CompanyShorthand        -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId   A change to AvsId as primary key is too much work and not strictly necessary due to Uniqueness
-  avsId           Int     default=0       -- primary key from avs, use negative numbers for non-AVS companies 
-  prefersPostal   Bool    default=true    -- new company users prefers letters by post instead of email
-  postAddress     StoredMarkup Maybe      -- default company postal address, including company name 
-  email           UserEmail Maybe         -- Case-insensitive generic company eMail address  
-  pinPassword     Bool    default=true    -- new company users only: should sensitive PDF email attachement be protected by a password?
-  -- UniqueCompanyName name               -- Should be Unique in AVS, but we do not yet need to enforce it
-  -- UniqueCompanyShorthand shorthand     -- unnecessary, since it is the primary key already
-  UniqueCompanyAvsId avsId                -- Should be the key, is not for historical reasons and for convenience in URLs and columns
-  Primary shorthand                       -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } 
-  deriving Ord Eq Show Generic Binary
-

backend/src/Foundation/Yesod/StaticContent.hs

@@ -1,53 +0,0 @@
--- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel <sarah.vaupel@uniworx.systems>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Foundation.Yesod.StaticContent
-  ( addStaticContent
-  ) where
-
-import Import.NoFoundation hiding (addStaticContent)
-
-import Foundation.Type
-
-import qualified Database.Memcached.Binary.IO as Memcached
-
-import qualified Data.ByteString.Lazy as Lazy
-import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded)
-import Data.ByteArray (convert)
-import Crypto.Hash (SHAKE256)
-import Crypto.Hash.Conduit (sinkHash)
-import Data.Bits (Bits(zeroBits))
-
-import qualified Data.Conduit.Combinators as C
-
-
-addStaticContent :: Text
-                 -> Text
-                 -> Lazy.ByteString
-                 -> HandlerFor UniWorX (Maybe (Either Text (Route UniWorX, [(Text, Text)])))
-addStaticContent ext _mime content = do
-  UniWorX{appWidgetMemcached, appSettings'} <- getYesod
-  for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
-    let expiry = maybe 0 ceiling memcachedExpiry
-        touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
-        addItem = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
-        absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
-    catchIf Memcached.isKeyNotFound touch . const $
-      handleIf Memcached.isKeyExists (const $ return ()) addItem
-    return . Left $ pack absoluteLink
-  where
-    -- Generate a unique filename based on the content itself, this is used
-    -- for deduplication so a collision resistant hash function is required
-    --
-    -- SHA-3 (SHAKE256) seemed to be a future-proof choice
-    --
-    -- Length of hash is 144 bits ~~instead of MD5's 128, so as to avoid
-    -- padding after base64-conversion~~ for backwards compatibility
-    fileName = (<.> unpack ext)
-             . unpack
-             . decodeUtf8
-             . Base64.encodeUnpadded
-             . (convert :: Digest (SHAKE256 144) -> ByteString)
-             . runConduitPure
-             $ C.sourceLazy content .| sinkHash

backend/src/Handler/Admin.hs

@@ -1,438 +0,0 @@
--- SPDX-FileCopyrightText: 2022-2025 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Handler.Admin
-  ( module Handler.Admin
-  ) where
-
-import Import
-
--- import Data.Either
-import qualified Data.Set  as Set
-import qualified Data.Map  as Map
-import qualified Data.Text as Text
--- import qualified Data.Text.Lazy.Encoding as LBS
-
--- import qualified Control.Monad.Catch as Catch
--- import Servant.Client (ClientError(..), ResponseF(..))
--- import Text.Blaze.Html (preEscapedToHtml)
-
-import Database.Persist.Sql (updateWhereCount)
-import           Database.Esqueleto.Experimental ((:&)(..))
-import qualified Database.Esqueleto.Experimental as E
-import qualified Database.Esqueleto.Legacy as EL (on) -- needed for dbTable
-import qualified Database.Esqueleto.Utils as E
-
-import Jobs
-import Utils.Company (areThereInsaneCompanySupervisions)
-import Handler.Utils
-import Handler.Utils.Avs
-import Handler.Utils.Users
--- import Handler.Utils.Company
-import Handler.Health.Interface
-import Handler.Users (AllUsersAction(..))
-
-import Handler.Admin.Test as Handler.Admin
-import Handler.Admin.ErrorMessage as Handler.Admin
-import Handler.Admin.Tokens as Handler.Admin
-import Handler.Admin.Crontab as Handler.Admin
-import Handler.Admin.Avs as Handler.Admin
-import Handler.Admin.Ldap as Handler.Admin
-
-
--- Types and Template Haskell
-data ProblemTableAction = ProblemTableMarkSolved
-                        | ProblemTableMarkUnsolved
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-  deriving anyclass (Universe, Finite)
-
-nullaryPathPiece ''ProblemTableAction $ camelToPathPiece' 2
-embedRenderMessage ''UniWorX ''ProblemTableAction id
-
-data ProblemTableActionData = ProblemTableMarkSolvedData
-                            | ProblemTableMarkUnsolvedData -- Placeholder, remove later
-  deriving (Eq, Ord, Read, Show, Generic)
-
-
--- Handlers
-getAdminR :: Handler Html
-getAdminR = redirect AdminProblemsR
-
-getAdminProblemsR, postAdminProblemsR :: Handler Html
-getAdminProblemsR = handleAdminProblems Nothing
-
-handleAdminProblems :: Maybe Widget -> Handler Html
-handleAdminProblems mbProblemTable = do
-  now <- liftIO getCurrentTime
-  let nowaday = utctDay now
-      cutOffOldDays = 1
-      cutOffOldTime  = toMidnight $ addDays (-cutOffOldDays) nowaday
-
-  -- we abuse messageTooltip for colored icons here
-  msgSuccessTooltip <- messageI Success MsgMessageSuccess
-  msgWarningTooltip <- messageI Warning MsgMessageWarning
-  msgErrorTooltip   <- messageI Error   MsgMessageError
-
-  let flagError   = messageTooltip . bool msgErrorTooltip   msgSuccessTooltip
-      flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
-      flagNonZero :: Int -> Widget
-      flagNonZero n | n <= 0    = flagError True
-                    | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
-
-      showDiffTime t =
-        let d = diffUTCTime now t
-        in guardMonoid (d > secondsToNominalDiffTime 30) [whamlet|<small>_{MsgProblemLastCheckTime (formatDiffDays d)}|]
-
-  (usersAreReachable, aurTime) <- areAllUsersReachable -- cached
-  (not -> thereAreInsaneFirmSupervisions, ifsTime) <- areThereInsaneCompanySupervisions -- cached
-  (driversHaveAvsIds, rDriversHaveFs, not -> noStalePrintJobs, not -> noBadAPCids) <- runDBRead $ (,,,)
-      <$> allDriversHaveAvsId now
-      <*> allRDriversHaveFs now
-      <*> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime]
-      <*> exists [PrintAcknowledgeProcessed ==. False]
-  (interfaceOks, interfaceTable) <- runDB $ mkInterfaceLogTable mempty
-  let interfacesBadNr = length $ filter (not . snd) interfaceOks
-      -- interfacesOk = all snd interfaceOks
-
-  diffLics <- try retrieveDifferingLicences >>= \case
-    -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
-    (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
-    (Right (AvsLicenceDifferences{..},_)) -> do
-      let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
-      void $ runDB $ queueAvsUpdateByAID problemIds $ Just nowaday
-      return $ Right
-        ( Set.size avsLicenceDiffRevokeAll
-        , Set.size avsLicenceDiffGrantVorfeld
-        , Set.size avsLicenceDiffRevokeRollfeld
-        , Set.size avsLicenceDiffGrantRollfeld
-        )
-  -- Attempt to format results in a nicer way failed, since rendering Html within a modal destroyed the page layout itself
-  -- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2)
-  -- diffLics <- (procDiffLics . fst <$> retrieveDifferingLicences) `catches`
-  --   [ Catch.Handler (\case (UnsupportedContentType "text/html;charset=utf-8" Response{responseBody})
-  --                                         -> return $ Left $ toWidget $ preEscapedToHtml $ fromRight "Response UTF8-decoding error" $ LBS.decodeUtf8' responseBody
-  --                          ex             -> return $ Left $ text2widget $ tshow ex)
-  --   , Catch.Handler (\(ex::SomeException) -> return $ Left $ text2widget $ tshow ex)
-  --   ]
-
-  rerouteMail <- getsYesod $ view _appMailRerouteTo
-  problemLogTable <- maybeM (snd <$> runDB mkProblemLogTable) return $ return mbProblemTable    -- formResult only processed in POST-Handler
-
-  siteLayoutMsg MsgProblemsHeading $ do
-    setTitleI   MsgProblemsHeading
-    $(widgetFile "admin-problems")
-
-postAdminProblemsR = do
-    (problemLogRes, problemLogTable) <- runDB mkProblemLogTable
-    formResult problemLogRes procProblems
-    handleAdminProblems $ Just problemLogTable
-  where
-    procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler ()
-    procProblems (ProblemTableMarkSolvedData  , pids) = actUpdate True  pids
-    procProblems (ProblemTableMarkUnsolvedData, pids) = actUpdate False pids
-
-    actUpdate markdone pids = do
-      mauid <- maybeAuthId
-      now <- liftIO getCurrentTime
-      let (pls_fltr,newv,msg) | markdone  = (ProblemLogSolved ==. Nothing, Just now, MsgAdminProblemsSolved)
-                              | otherwise = (ProblemLogSolved !=. Nothing, Nothing , MsgAdminProblemsReopened)
-      (fromIntegral -> oks) <- runDB $ updateWhereCount [pls_fltr, ProblemLogId <-. toList pids]
-                                                        [ProblemLogSolved =. newv, ProblemLogSolver =. mauid]
-      let no_req = Set.size pids
-          mkind = if oks < no_req || no_req <= 0 then Warning else Success
-      addMessageI mkind $ msg oks
-      when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables
-
-getProblemUnreachableR,  postProblemUnreachableR :: Handler Html
-getProblemUnreachableR = postProblemUnreachableR
-postProblemUnreachableR = do
-  unreachables <- runDBRead retrieveUnreachableUsers
-
-  -- the following form is a nearly identicaly copy from Handler.Users:
-  ((noreachUsersRes, noreachUsersWgt'), noreachUsersEnctype) <- runFormPost . identifyForm FIDUnreachableUsersAction $ buttonForm
-  let noreachUsersWgt = wrapForm noreachUsersWgt' def
-        { formSubmit = FormNoSubmit
-        , formAction = Just $ SomeRoute ProblemUnreachableR
-        , formEncoding = noreachUsersEnctype
-        }
-  formResult noreachUsersRes $ \case
-    AllUsersLdapSync -> do
-      forM_ unreachables $ \Entity{entityKey=uid} -> void . queueJob $ JobSynchroniseLdapUser uid
-      addMessageI Success . MsgSynchroniseLdapUserQueued $ length unreachables
-      redirect ProblemUnreachableR
-    AllUsersAvsSync -> do
-      n <- runDB $ queueAvsUpdateByUID (entityKey <$> unreachables) Nothing
-      addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n
-      redirect ProblemUnreachableR
-
-  siteLayoutMsg MsgProblemsUnreachableHeading $ do
-    setTitleI   MsgProblemsUnreachableHeading
-    [whamlet|
-      <section>
-        <h3>_{MsgProblemsUnreachableButtons}
-        ^{noreachUsersWgt}
-      <section>
-        #{length unreachables} _{MsgProblemsUnreachableBody}
-        <ul>
-          $forall usr <- unreachables
-            <li>
-              ^{linkUserWidget ForProfileDataR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
-    |]
-
-getProblemFbutNoR :: Handler Html
-getProblemFbutNoR = do
-  now <- liftIO getCurrentTime
-  rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now
-  siteLayoutMsg MsgProblemsRWithoutFHeading $ do
-    setTitleI   MsgProblemsRWithoutFHeading
-    [whamlet|
-      <section>
-        _{MsgProblemsRWithoutFBody}
-        <ul>
-          $forall usr <- rnofs
-            <li>
-              ^{linkUserWidget AdminUserR usr}
-    |]
-
-getProblemWithoutAvsId :: Handler Html
-getProblemWithoutAvsId = do
-  now <- liftIO getCurrentTime
-  rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now
-  siteLayoutMsg MsgProblemsNoAvsIdHeading $ do
-    setTitleI   MsgProblemsNoAvsIdHeading
-    [whamlet|
-      <section>
-        _{MsgProblemsNoAvsIdBody}
-        <ul>
-          $forall usr <- rnofs
-            <li>
-              ^{linkUserWidget AdminUserR usr}
-    |]
-
-{-
-mkUnreachableUsersTable = do
-  let dbtSQLQuery user -> do
-        E.where_ $ E.isNothing (user E.^. UserPostAddress)
-          E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
-        pure user
-      dbtRowKey = (E.^. UserId)
-      dbtProj = dbtProjId
-      dbtColonnade =
--}
-
-areAllUsersReachable :: Handler (Bool, UTCTime)
-areAllUsersReachable = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-users-reachable|] $ do
-  now <- liftIO getCurrentTime
-  res <- runDBRead retrieveUnreachableUsers
-  -- res <- E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone
-  $logInfoS "sanity" [st|Are there insane company supervisions: #{tshow res}|]
-  return (null res,now)
-
--- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User))
--- retrieveUnreachableUsers' = do
---     user <- E.from $ E.table @User
---     E.where_ $   E.isNothing (user E.^. UserPostAddress)
---           E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
---           E.&&. E.not_ ((user E.^. UserDisplayEmail)  `E.like` E.val "%@%.%")
---           E.&&. E.not_ ((user E.^. UserEmail)         `E.like` E.val "%@%.%")
---     return user
-
-retrieveUnreachableUsers :: DBReadUq' [Entity User]
-retrieveUnreachableUsers = do
-    emailOnlyUsers <- E.select $ do
-      user <- E.from $ E.table @User
-      E.where_ $   E.isNothing (user E.^. UserPostAddress)
-            E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
-            E.&&. E.notExists (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_ $ user E.^. UserId E.==. usrCmp E.^. UserCompanyUser
-                    E.&&.  usrCmp E.^. UserCompanyUseCompanyAddress
-                    E.&&.  E.isJust (cmp E.^. CompanyPostAddress)
-              )
-      return user
-    filterM hasInvalidEmail emailOnlyUsers
-    -- filterM hasInvalifPostal -- probably not worth it, since Utils.Postal.validPostAddress is pretty weak anyway
-  where
-    hasInvalidEmail = fmap isNothing . getUserEmail
-
-
-allDriversHaveAvsId :: UTCTime -> DBReadUq Bool
--- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
-allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId
-
-{-
--- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known
-retrieveDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
-retrieveDriversWithoutAvsId' nowaday = do
-  (usr :& qualUsr :& qual) <- E.from $ E.table @User
-    `E.innerJoin`  E.table @QualificationUser
-    `E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser)
-    `E.innerJoin`  E.table @Qualification
-    `E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)
-  E.where_ $ -- is avs licence
-      E.isJust (qual E.^. QualificationAvsLicence)
-    E.&&. (qualUsr & validQualification nowaday)
-    E.&&. -- AvsId is unknown
-      E.notExists (do
-        avsUsr <- E.from $ E.table @UserAvs
-        E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
-      )
-  return usr
--}
-
--- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
-retrieveDriversWithoutAvsId :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
-retrieveDriversWithoutAvsId now = do
-  usr <- E.from $ E.table @User
-  E.where_ $
-      E.exists (do -- a valid avs licence
-        (qual :& qualUsr) <- E.from (E.table @Qualification
-              `E.innerJoin` E.table @QualificationUser
-              `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
-        E.where_ $ -- is avs licence
-            E.isJust (qual E.^. QualificationAvsLicence)
-          E.&&. (qualUsr & validQualification now) -- currently valid
-          E.&&. -- matches user
-            (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)
-      )
-    E.&&.
-      E.notExists (do -- a known AvsId
-        avsUsr <- E.from $ E.table @UserAvs
-        E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
-      )
-  return usr
-
-
-allRDriversHaveFs :: UTCTime -> DBReadUq Bool
--- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
-allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF
-
--- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
-retrieveDriversRWithoutF :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
-retrieveDriversRWithoutF now = do
-  usr <- E.from $ E.table @User
-  let hasValidQual lic = do
-        (qual :& qualUsr) <- E.from (E.table @Qualification
-              `E.innerJoin` E.table @QualificationUser
-              `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
-        E.where_ $  (qual E.^. QualificationAvsLicence  E.==. E.justVal lic)    -- matches licence
-              E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)  -- matches user
-              E.&&. (qualUsr & validQualification now)                          -- currently valid
-  E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
-    E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
-  return usr
-
-
-
-type ProblemLogTableExpr = E.SqlExpr (Entity ProblemLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
-queryProblem :: ProblemLogTableExpr -> E.SqlExpr (Entity ProblemLog)
-queryProblem = $(E.sqlLOJproj 3 1)
-
-querySolver :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User))
-querySolver = $(E.sqlLOJproj 3 2)
-
-queryUser :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User))
-queryUser = $(E.sqlLOJproj 3 3)
-
-type ProblemLogTableData = DBRow (Entity ProblemLog, Maybe (Entity User), Maybe (Entity User))
-resultProblem :: Lens' ProblemLogTableData (Entity ProblemLog)
-resultProblem = _dbrOutput . _1
-
-resultSolver :: Traversal' ProblemLogTableData (Entity User)
-resultSolver = _dbrOutput . _2 . _Just
-
-resultUser :: Traversal' ProblemLogTableData (Entity User)
-resultUser = _dbrOutput . _3 . _Just
-
-mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget)
-mkProblemLogTable = do
-    -- problem_types <- E.select $ do
-    --   ap <- E.from $ E.table @ProblemLog
-    --   let res = ap E.^. ProblemLogInfo E.->>. "problem"
-    --   E.groupBy res
-    --   return res
-    over _1 postprocess <$> dbTable validator DBTable{..}
-  where
-    -- TODO: query to collect all occurring problem types to use as tooltip for the problem filter, so that these don't run out of synch
-    dbtIdent = "problem-log" :: Text
-    dbtSQLQuery = \(problem `E.LeftOuterJoin` solver `E.LeftOuterJoin` usr) -> do
-                    -- EL.on (usr    E.?. UserId E.==. E.text2num (problem E.^. ProblemLogInfo   E.->>. "user")) -- works
-                    EL.on (usr    E.?. UserId E.==. problem E.^. ProblemLogInfo E.->>>. "user")
-                    EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver)
-                    return (problem, solver, usr)
-    dbtRowKey = queryProblem >>> (E.^. ProblemLogId)
-    dbtProj = dbtProjFilteredPostId
-    dbtColonnade = formColonnade $ mconcat
-      [ dbSelect (applying _2) id $ return . view (resultProblem . _entityKey)
-      , sortable (Just "time")    (i18nCell MsgAdminProblemCreated) $ \(   view $ resultProblem . _entityVal . _problemLogTime   -> t) ->           dateTimeCell t
-      , sortable (Just "info")    (i18nCell MsgAdminProblemInfo)    $ \(   view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> adminProblemCell p
-      -- , sortable (Just "firm")    (i18nCell MsgTableCompany)        $ \(preview $ resultProblem . _entityVal . _problemLogAdminProblem . _adminProblemCompany -> c) -> cellMaybe companyIdCell c
-      , sortable (Just "firm")    (i18nCell MsgTableCompany)        $ \(   view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> cellMaybe companyIdCell $ join (p ^? _adminProblemCompanyOld) <|> (p ^? _adminProblemCompany)
-      , sortable (Just "user")    (i18nCell MsgAdminProblemUser)    $ \(preview resultUser   -> u) -> maybeCell u $ cellHasUserLink AdminUserR
-      , 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 = 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 = 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
-            return $ crit `Text.isInfixOf` protxt
-        )
-      ]
-    dbtFilterUI mPrev = mconcat
-      [ prismAForm (singletonFilter "user"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgAdminProblemUser   & setTooltip MsgTableFilterCommaPlus)
-      , prismAForm (singletonFilter "solver"  . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgAdminProblemSolver & setTooltip MsgTableFilterCommaPlusShort)
-      , prismAForm (singletonFilter "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgAdminProblemInfo)
-      , prismAForm (singletonFilter "company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgTableCompanyShort)
-      , prismAForm (singletonFilter "solved"  . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved)
-      ]
-    acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData)
-    acts = Map.fromList
-      [ (ProblemTableMarkSolved   , pure ProblemTableMarkSolvedData)
-      , (ProblemTableMarkUnsolved , pure ProblemTableMarkUnsolvedData)
-      ]
-    dbtParams = DBParamsForm
-          { dbParamsFormMethod = POST
-          , dbParamsFormAction = Nothing
-          , dbParamsFormAttrs  = []
-          , dbParamsFormSubmit = FormSubmit
-          , dbParamsFormAdditional
-              = renderAForm FormStandard
-                   $  (, mempty) . First . Just
-                  <$> multiActionA acts (fslI MsgTableAction) (Just ProblemTableMarkSolved)
-          , dbParamsFormEvaluate = liftHandler . runFormPost
-          , dbParamsFormResult   = id
-          , dbParamsFormIdent    = def
-          }
-    dbtCsvEncode = noCsvEncode
-    dbtCsvDecode = Nothing
-    dbtExtraReps = []
-    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
-    validator = def & defaultSorting [SortAscBy "time"]
-                    & defaultFilter  (singletonMap "solved" [toPathPiece False])
-    postprocess :: FormResult (First ProblemTableActionData, DBFormResult ProblemLogId Bool ProblemLogTableData)
-                -> FormResult (      ProblemTableActionData, Set ProblemLogId)
-    postprocess inp = do
-      (First (Just act), usrMap) <- inp
-      let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
-      return (act, usrSet)
-
--- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a -- moved to Handler.Utils
--- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) -- moved to Handler.Utils

backend/src/Handler/CommCenter.hs

@@ -1,150 +0,0 @@
--- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Handler.CommCenter
-  ( getCommCenterR
-  ) where
-
-import Import
-import Handler.Utils
-
--- import qualified Data.Set as Set
-import qualified Data.Map as Map
--- import qualified Data.Text as Text
-import Data.Text.Lens (packed)
-
--- 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 qualified Database.Esqueleto.PostgreSQL as E
-import Database.Esqueleto.Utils.TH
-
-
-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)
-
-instance Universe CCTableAction
-instance Finite CCTableAction
-nullaryPathPiece ''CCTableAction $ camelToPathPiece' 2
-embedRenderMessage ''UniWorX ''CCTableAction id
-
-data CCTableActionData  = CCActDummyData
-  deriving (Eq, Ord, Read, Show, Generic)
-
-
--- SJ: I don't know how to use E.unionAll_ with dbTable, so we simulate it by a FullOuterJoin with constant False ON-clause instead
-type CCTableExpr =
-  (                   (E.SqlExpr (Maybe (Entity User))  `E.InnerJoin` E.SqlExpr (Maybe (Entity SentMail)))
-    `E.FullOuterJoin` (E.SqlExpr (Maybe (Entity User))  `E.InnerJoin` E.SqlExpr (Maybe (Entity PrintJob)))
-  )
-
-queryRecipientMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
-queryRecipientMail = $(sqlIJproj 2 1) . $(sqlFOJproj 2 1)
-
-queryMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity SentMail))
-queryMail = $(sqlIJproj 2 2) . $(sqlFOJproj 2 1)
-
-queryRecipientPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
-queryRecipientPrint = $(sqlIJproj 2 1) . $(sqlFOJproj 2 2)
-
-queryPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity PrintJob))
-queryPrint = $(sqlIJproj 2 2) . $(sqlFOJproj 2 2)
-
-type CCTableData = DBRow (Maybe (Entity User), Maybe (Entity SentMail), Maybe (Entity User), Maybe (Entity PrintJob))
-
-resultRecipientMail :: Traversal' CCTableData (Entity User)
-resultRecipientMail = _dbrOutput . _1 . _Just
-
-resultMail :: Traversal' CCTableData (Entity SentMail)
-resultMail = _dbrOutput . _2 . _Just
-
-resultRecipientPrint :: Traversal' CCTableData (Entity User)
-resultRecipientPrint = _dbrOutput . _3 . _Just
-
-resultPrint :: Traversal' CCTableData (Entity PrintJob)
-resultPrint = _dbrOutput . _4 . _Just
-
-
-mkCCTable :: DB (Any, Widget)
-mkCCTable = do
-  let
-    dbtSQLQuery :: CCTableExpr -> E.SqlQuery (E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity SentMail)), E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity PrintJob)))
-    dbtSQLQuery  ((recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (recipientPrint `E.InnerJoin` printJob)) = do
-      EL.on $ recipientMail  E.?. UserId E.==. E.joinV (mail     E.?. SentMailRecipient)
-      EL.on $ recipientPrint E.?. UserId E.==. E.joinV (printJob E.?. PrintJobRecipient)
-      -- EL.on $ recipientMail  E.?. UserId E.==. recipientPrint E.?. UserId E.&&. E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
-      EL.on E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
-      -- E.where_ $ E.isJust (recipientMail E.?. UserId) E.||. E.isJust (recipientPrint E.?. UserId) -- not needed for full outer join
-      -- return (E.coalesce[recipientMail, recipientPrint], mail, print) -- coalesce only works on values, not entities
-      return (recipientMail,  mail, recipientPrint, printJob)
-    -- dbtRowKey = (,) <$> views (to queryMail) (E.?. SentMailId) <*> views (to queryPrint) (E.?. PrintJobId)
-    dbtRowKey ((_recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (_recipientPrint `E.InnerJoin` printJob)) = (mail E.?. SentMailId, printJob E.?. PrintJobId)
-
-    dbtProj = dbtProjId
-    dbtColonnade = dbColonnade $ mconcat -- prefer print over email in the impossible case that both are Just
-      [ sortable (Just "date")      (i18nCell MsgPrintJobCreated)       $ \row ->
-          let tprint  = row ^? resultPrint  . _entityVal . _printJobCreated
-              tmail   = row ^? resultMail   . _entityVal . _sentMailSentAt
-          in maybeCell (tprint <|> tmail) dateTimeCell
-      , sortable (Just "recipient") (i18nCell MsgPrintRecipient)        $ \row ->
-          let uprint = row ^? resultRecipientPrint
-              umail  = row ^? resultRecipientMail
-          in  maybeCell (uprint <|> umail) $ cellHasUserLink AdminUserR
-      , sortable Nothing (i18nCell MsgCommBody) $ \row -> if
-          | (Just k) <- row ^? resultPrint . _entityKey
-            -> anchorCellM (PrintDownloadR <$> encrypt k) $ toWgt (iconLetterOrEmail True ) <> text2widget "-link"
-          | (Just k) <- row ^? resultMail  . _entityKey
-            -> anchorCellM (MailHtmlR      <$> encrypt k) $ toWgt (iconLetterOrEmail False) <> text2widget "-link"
-          | otherwise
-            -> mempty
-      , sortable Nothing (i18nCell MsgCommSubject) $ \row ->
-          let tsubject = row ^? resultPrint . _entityVal . _printJobFilename . packed
-              msubject = row ^? resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
-          in maybeCell (tsubject <|> msubject) textCell
-      ]
-    dbtSorting = mconcat
-      [ singletonMap "date"       $ SortColumn  $ \row -> E.coalesce [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt]
-      , singletonMap "recipient"  $ SortColumns $ \row ->
-          [ SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserSurname    , queryRecipientMail row E.?. UserSurname    ]
-          , SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]
-          ]
-      ]
-    dbtFilter = Map.fromList
-      [ ("sentTo"    , 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
-      , ("sentFrom"  , FilterColumn . E.mkDayFilterFrom
-                  $ \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  ])
-      ]
-    dbtFilterUI mPrev = mconcat
-      [ prismAForm (singletonFilter "sentTo"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgTableFilterSentBefore)
-      , prismAForm (singletonFilter "sentFrom"  . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgTableFilterSentAfter)
-      , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
-      , prismAForm (singletonFilter "subject"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommSubject    & setTooltip MsgTableFilterCommaPlusShort)
-      ]
-    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
-    dbtIdent :: Text
-    dbtIdent = "comms"
-    dbtCsvEncode = noCsvEncode
-    dbtCsvDecode = Nothing
-    dbtExtraReps = []
-    dbtParams = def
-    psValidator = def & defaultSorting [SortDescBy "date"]
-  dbTable psValidator DBTable{..}
-
-getCommCenterR :: Handler Html
-getCommCenterR = do
-  (_, ccTable) <- runDB mkCCTable
-  siteLayoutMsg MsgMenuCommCenter $ do
-    setTitleI MsgMenuCommCenter
-    $(widgetFile "comm-center")
-

backend/src/Handler/Firm/Supervision.hs

@@ -1,234 +0,0 @@
--- SPDX-FileCopyrightText: 2023-2025 Steffen Jost <S.Jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# LANGUAGE TypeApplications #-}
-
-module Handler.Firm.Supervision
-  ( getFirmsSupervisionR , postFirmsSupervisionR
-  )
-  where
-
-import Import
-
--- import Jobs
-import Utils.Company
-import Handler.Utils
-import Handler.Utils.Company
-
-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
--- import qualified Data.Csv as Csv
--- import qualified Data.Text as T
-import qualified Data.CaseInsensitive as CI
--- import qualified Data.Conduit.List as C
--- import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
-import Database.Persist.Postgresql
-import           Database.Esqueleto.Experimental ((:&)(..))
-import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
-import qualified Database.Esqueleto.Legacy as EL (on) -- needed for legacy join expected by dbTable
--- import qualified Database.Esqueleto.PostgreSQL as E
-import qualified Database.Esqueleto.Utils as E
--- import Database.Esqueleto.Utils.TH
-
-
--- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
--- decryptUser = decrypt
-
--- encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser
--- encryptUser = encrypt
-
-
------------------------
--- Supervision Sanity
-
-data ActSupervision = ASChangeCompany | ASRemoveAssociation
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-  deriving anyclass (Universe, Finite)
-
-nullaryPathPiece ''ActSupervision $ camelToPathPiece' 2
-embedRenderMessage ''UniWorX ''ActSupervision id
-
-data ActSupervisionData
-    = ASChangeCompanyData     { asTblCompany :: Maybe CompanyShorthand, asTblReason  :: Maybe Text }
-    | ASRemoveAssociationData
-  deriving (Eq, Ord, Read, Show, Generic)
-
-data SupervisionViolation = SupervisionViolationEither | SupervisionViolationClient | SupervisionViolationSupervisor | SupervisionViolationBoth
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-  deriving anyclass (Universe, Finite)
-
-nullaryPathPiece ''SupervisionViolation $ camelToPathPiece' 1
-embedRenderMessage ''UniWorX ''SupervisionViolation id
-
-supervisionViolationField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m SupervisionViolation
--- supervisionViolationField = radioGroupField (Just $ SomeMessage MsgSupervisionViolationEither) $ optionsFinite
-supervisionViolationField = radioGroupField Nothing $ optionsFinite
-
-type TblSupervisionData = DBRow (Entity UserSupervisor, Entity User, Entity User)
-
-mkSupervisionTable :: DB (FormResult (ActSupervisionData, Set UserSupervisorId), Widget)
-mkSupervisionTable = over _1 postprocess <$> dbTable validator DBTable{..}
-  where
-    dbtIdent = "sanity-super" :: Text
-    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
-
-    queryRelation   :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserSupervisor)
-    queryRelation   = $(E.sqlIJproj 3 1)
-    querySupervisor :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
-    querySupervisor = $(E.sqlIJproj 3 2)
-    queryClient     :: (E.SqlExpr (Entity UserSupervisor) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
-    queryClient     = $(E.sqlIJproj 3 3)
-
-    resultRelation    :: Lens' TblSupervisionData (Entity UserSupervisor)
-    resultRelation    =  _dbrOutput . _1
-    resultSupervisor  :: Lens' TblSupervisionData (Entity User)
-    resultSupervisor  =  _dbrOutput . _2
-    resultClient      :: Lens' TblSupervisionData (Entity User)
-    resultClient      =  _dbrOutput . _3
-
-    dbtSQLQuery (uus `E.InnerJoin` spr `E.InnerJoin` sub) = do
-      EL.on $ uus E.^. UserSupervisorSupervisor E.==. spr E.^. UserId
-      EL.on $ uus E.^. UserSupervisorUser       E.==. sub E.^. UserId
-      E.where_ $ E.isJust (uus E.^. UserSupervisorCompany)
-      return (uus, spr, sub)
-    dbtRowKey = queryRelation >>> (E.^. UserSupervisorId)
-    dbtProj = dbtProjId
-    dbtColonnade = formColonnade $ mconcat
-      [ dbSelect (applying _2) id (return . view (resultRelation . _entityKey))
-      , sortable (Just "reroute")     (i18nCell MsgTableRerouteActive)    $ \(view $ resultRelation . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
-      , sortable (Just "reason")      (i18nCell MsgUserSupervisorReason)  $ \(view $ resultRelation . _entityVal . _userSupervisorReason  -> r) -> maybeCell r textCell
-      , sortable (Just "rel-comp")    (i18nCell MsgUserSupervisorCompany) $ \(view $ resultRelation . _entityVal . _userSupervisorCompany -> c) -> maybeCell c companyIdCell\
-      , sortable (Just "supervisor")  (i18nCell MsgTableSupervisor)       $ \(view $ resultSupervisor  -> u) -> cellHasUserModal ForProfileDataR u
-      , sortable (Just "super-comp")  (i18nCell MsgTableCompanies)        $ \(view $ resultSupervisor  . _entityKey -> uid) -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
-          maybeMonoid <$> wgtCompanies True uid
-      , sortable (Just "client") (i18nCell MsgTableSupervisee)       $ \(view $ resultClient -> u) -> cellHasUserModal ForProfileDataR u
-      , sortable (Just "client-comp") (i18nCell MsgTableCompanies)        $ \(view $ resultClient . _entityKey -> uid) -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
-          maybeMonoid <$> wgtCompanies True uid
-      ]
-    validator = def & defaultSorting [SortAscBy "rel-comp", SortAscBy "supervisor", SortAscBy "client"]
-                    & defaultFilter  (singletonMap "violation" [toPathPiece SupervisionViolationEither])
-    dbtSorting = Map.fromList
-      [ ("reason"       , SortColumn $ queryRelation    >>> (E.^. UserSupervisorReason))
-      , ("rel-comp"     , SortColumn $ queryRelation    >>> (E.^. UserSupervisorCompany))
-      , ("reroute"      , SortColumn $ queryRelation    >>> (E.^. UserSupervisorRerouteNotifications))
-      , ("supervisor"   , SortColumn $ querySupervisor  >>> (E.^. UserDisplayName))
-      , ("client"       , SortColumn $ queryClient >>> (E.^. UserDisplayName))
-      , ("super-comp"   , 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.==. querySupervisor  row E.^. UserId
-            E.orderBy [E.asc $ cmp E.^. CompanyName]
-            return (cmp E.^. CompanyName)
-          ))
-      , ("client-comp"  , 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.==. queryClient row E.^. UserId
-            E.orderBy [E.asc $ cmp E.^. CompanyName]
-            return (cmp E.^. CompanyName)
-          ))
-      ]
-
-    dbtFilter = Map.fromList
-      [ ("violation", FilterColumn $ \(queryRelation -> us) (getLast -> criterion) -> case criterion of
-          Just SupervisionViolationSupervisor  -> missingCompanySupervisor us
-          Just SupervisionViolationClient ->                                   missingCompanyClient us
-          Just SupervisionViolationBoth        -> missingCompanySupervisor us E.&&. missingCompanyClient us
-          _                                    -> missingCompanySupervisor us E.||. missingCompanyClient us
-        )
-      , ("rel-company", FilterColumn $ E.mkExistsFilter $ \(queryRelation -> us) (commaSeparatedText -> criteria) -> do
-          let numCrits    = setMapMaybe readMay criteria
-          cmp <- E.from $ E.table @Company
-          E.where_ $ cmp E.^. CompanyId E.=?. us E.^. UserSupervisorCompany
-              E.&&. E.or (
-                      bcons (notNull numCrits)
-                      (E.mkExactFilter (E.^. CompanyAvsId) cmp numCrits)
-                      [E.mkContainsFilterWith CI.mk (E.^. CompanyName) cmp criteria
-                      ,E.mkContainsFilterWith CI.mk (E.^. CompanyShorthand) cmp criteria
-                      ]
-                    )
-        )
-      , ("supervisor-company", fltrCompanyShortNrUsr (querySupervisor  >>> (E.^. UserId)))
-      , ("client-company"    , fltrCompanyShortNrUsr (queryClient >>> (E.^. UserId)))
-      , ("supervisor", FilterColumn . E.mkContainsFilter $ querySupervisor >>> (E.^. UserDisplayName))
-      , ("client"    , FilterColumn . E.mkContainsFilter $ queryClient     >>> (E.^. UserDisplayName))
-      ]
-    dbtFilterUI mPrev = mconcat                  --  Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text])
-      [ prismAForm (singletonFilter "violation" . maybePrism _PathPiece) mPrev $ aopt supervisionViolationField (fslI MsgSupervisionViolationChoice)
-      , prismAForm (singletonFilter "rel-company")     mPrev $ aopt textField (fslI MsgUserSupervisorCompany & setTooltip MsgTableFilterCommaNameNr)
-      , prismAForm (singletonFilter "supervisor")      mPrev $ aopt textField (fslI MsgTableSupervisor)
-      , fltrCompanyNameNrUsrHdrUI "supervisor-company" (someMessages [MsgTableSupervisor, MsgTableCompanyShort]) mPrev
-      , prismAForm (singletonFilter "client")          mPrev $ aopt textField (fslI MsgTableSupervisee)
-      , fltrCompanyNameNrUsrHdrUI "client-company"     (someMessages [MsgTableSupervisee, MsgTableCompanyShort]) mPrev
-      ]
-
-    suggestionSupervision :: Handler (OptionList Text)
-    suggestionSupervision = mkOptionListText <$> runDB
-      (E.select $ do
-        us <- E.from $ E.table @UserSupervisor
-        let reason = us E.^. UserSupervisorReason
-            countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
-        E.where_ $ E.isJust reason
-        E.groupBy reason
-        E.orderBy [E.desc countRows']
-        E.limit 9
-        pure $ E.coalesceDefault [reason] (E.val "")
-      )
-    dbtParams = DBParamsForm
-      { dbParamsFormMethod = POST
-      , dbParamsFormAction = Nothing
-      , dbParamsFormAttrs  = []
-      , dbParamsFormSubmit = FormSubmit
-      , dbParamsFormAdditional =
-          let acts :: Map ActSupervision (AForm Handler ActSupervisionData)
-              acts = mconcat
-                      [ singletonMap ASChangeCompany $ ASChangeCompanyData
-                          <$> aopt companyField (fslI MsgUserSupervisorCompany) Nothing
-                          <*> aopt (textField & cfStrip & addDatalist suggestionSupervision) (fslI MsgUserSupervisorReason  & setTooltip MsgStarKeepsEmptyDeletes) (Just $ Just "*")
-                      , singletonMap ASRemoveAssociation $ pure ASRemoveAssociationData
-                      ]
-          in renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing
-      , dbParamsFormEvaluate = liftHandler . runFormPost
-      , dbParamsFormResult   = id
-      , dbParamsFormIdent    = def
-      }
-    dbtCsvEncode = noCsvEncode
-    dbtCsvDecode = Nothing
-    dbtExtraReps = []
-
-    postprocess :: FormResult (First ActSupervisionData, DBFormResult UserSupervisorId Bool TblSupervisionData)
-                -> FormResult (      ActSupervisionData, Set UserSupervisorId)
-    postprocess inp = do
-        (First (Just act), jobMap) <- inp
-        let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
-        return (act, jobSet)
-
-
-getFirmsSupervisionR, postFirmsSupervisionR :: Handler Html
-getFirmsSupervisionR = postFirmsSupervisionR
-postFirmsSupervisionR = do
-  (svRes, svTbl) <- runDB mkSupervisionTable
-  formResult svRes $ \case
-    (ASRemoveAssociationData, relations) -> do
-      nrDel <- runDB $ deleteWhereCount [UserSupervisorId <-. Set.toList relations]
-      addMessageOutOfI MsgSupervisionsRemoved nrDel $ Set.size relations
-      reloadKeepGetParams FirmsSupervisionR
-    (ASChangeCompanyData{..}, relations) -> do
-      let rsnChg = case asTblReason of
-                      Just "*" -> Nothing
-                      _        -> Just $ UserSupervisorReason =. asTblReason
-          chgs = mcons rsnChg [UserSupervisorCompany =. CompanyKey <$> canonical asTblCompany]
-      nrChg <- runDB $ updateWhereCount [UserSupervisorId <-. Set.toList relations] chgs
-      addMessageOutOfI MsgSupervisionsEdited nrChg $ Set.size relations
-      reloadKeepGetParams FirmsSupervisionR
-  -- TODO: Bug Firmenwechsel: Bestehende Ansprechpartnerbeziehung - Firma ändern!
-  let heading = MsgMenuFirmsSupervision
-  siteLayoutMsg heading $ do
-    setTitleI heading
-    [whamlet|$newline never
-      <p>
-        _{MsgFirmSupervisionRInfo} In folgenden Ansprechpartnerbeziehungen gehören entweder der Ansprechpartner oder der Angesprochene #
-        nicht mehr der Firma an, welche als Begründung für die Beziehung eingetragen ist:
-      <p>
-        ^{svTbl}
-    |]

backend/src/Handler/LMS/Learners.hs

@@ -1,339 +0,0 @@
--- SPDX-FileCopyrightText: 2023-2025 Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
-
-module Handler.LMS.Learners
-  ( getLmsLearnersR
-  , getLmsLearnersDirectR
-  , getLmsOrphansR
-  )
-  where
-
-
-import Import
-
-import Handler.Utils
-import Handler.Utils.Csv
-import Handler.Utils.LMS
-
-import qualified Data.Map as Map
-import qualified Data.Csv as Csv
-import qualified Data.Char as Char
-import qualified Data.Text as Text
-import qualified Data.Conduit.List as C
-import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
-import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.Utils as E
-
-data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
-  { csvLUTident :: LmsIdent
-  , csvLUTpin   :: Text
-  , csvLUTresetPin, csvLUTdelete, csvLUTstaff -- V1
-  , csvLUTresetTries, csvLUTlock :: LmsBool   -- V2
-  }
-  deriving Generic
-makeLenses_ ''LmsUserTableCsv
-
-lmsUserDelete2csv :: LmsIdent -> LmsUserTableCsv
-lmsUserDelete2csv lid = LmsUserTableCsv
-  { csvLUTident     = lid
-  , csvLUTpin       = "00000000"
-  , csvLUTresetPin  = LmsBool False
-  , csvLUTdelete    = LmsBool $ isJust $ Text.find Char.isLetter $ getLmsIdent lid    -- safety-catch: do not delete LMS Test-users, FRADrive LMS Idents always contain at least one letter
-  , csvLUTstaff     = LmsBool False
-  , csvLUTresetTries= LmsBool False
-  , csvLUTlock      = LmsBool True
-  }
-
--- | Mundane conversion needed for direct download without dbTable only
-lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv
-lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
-  { csvLUTident     = lmsUserIdent
-  , csvLUTpin       = lmsUserPin
-  , csvLUTresetPin  = LmsBool  lmsUserResetPin
-  , csvLUTdelete    = LmsBool (lmsUserToDelete cutoff lu)
-  , csvLUTstaff     = LmsBool (lmsUserStaff lu)
-  , csvLUTresetTries= LmsBool (lmsUserToResetTries lu) -- TODO: verify this works as intended!
-  , csvLUTlock      = LmsBool (lmsUserToLock lu)
-  }
-
--- csv without headers
-instance Csv.ToRecord   LmsUserTableCsv
-instance Csv.FromRecord LmsUserTableCsv
-
--- csv with headers
-lmsUserTableCsvHeader :: Csv.Header
-lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff, csvLmsResetTries, csvLmsLock ]
-
-instance ToNamedRecord LmsUserTableCsv where
-  toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord
-    [ csvLmsIdent       Csv..= csvLUTident
-    , csvLmsPin         Csv..= csvLUTpin
-    , csvLmsResetPin    Csv..= csvLUTresetPin
-    , csvLmsDelete      Csv..= csvLUTdelete
-    , csvLmsStaff       Csv..= csvLUTstaff
-    , csvLmsResetTries  Csv..= csvLUTresetTries
-    , csvLmsLock        Csv..= csvLUTlock
-    ]
-instance FromNamedRecord LmsUserTableCsv where
-  parseNamedRecord (lsfHeaderTranslate -> csv)
-    = LmsUserTableCsv
-        <$> csv Csv..: csvLmsIdent
-        <*> csv Csv..: csvLmsPin
-        <*> csv Csv..: csvLmsResetPin
-        <*> csv Csv..: csvLmsDelete
-        <*> csv Csv..: csvLmsStaff
-        <*> csv Csv..: csvLmsResetTries
-        <*> csv Csv..: csvLmsLock
-
-instance CsvColumnsExplained LmsUserTableCsv where
-  csvColumnsExplanations _ = Map.fromList
-    [ (csvLmsIdent      , msg2widget MsgCsvColumnLmsIdent)
-    , (csvLmsPin        , msg2widget MsgCsvColumnLmsPin)
-    , (csvLmsResetPin   , msg2widget MsgCsvColumnLmsResetPin)
-    , (csvLmsDelete     , msg2widget MsgCsvColumnLmsDelete)
-    , (csvLmsStaff      , msg2widget MsgCsvColumnLmsStaff)
-    , (csvLmsResetTries , msg2widget MsgCsvColumnLmsResetTries)
-    , (csvLmsLock       , msg2widget MsgCsvColumnLmsLock)
-    ]
-
-
-mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget)
-mkUserTable _sid qsh qid cutoff = do
-  dbtCsvName <- csvFilenameLmsUser qsh
-  let dbtCsvSheetName = dbtCsvName
-  let
-    userDBTable = DBTable{..}
-      where
-        dbtSQLQuery lmsuser = do
-          E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid
-              E.&&. E.isNothing (lmsuser E.^. LmsUserEnded)
-          return lmsuser
-        dbtRowKey = (E.^. LmsUserId)
-        dbtProj = dbtProjId
-        dbtColonnade = dbColonnade $ mconcat
-          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)      $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident
-          , sortable (Just csvLmsPin)       (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
-                                                                         )   $ \(view $ _dbrOutput . _entityVal . _lmsUserPin                  -> pin  ) -> textCell pin
-          , sortable (Just csvLmsResetPin)  (i18nCell MsgTableLmsResetPin)   $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin             -> reset) -> ifIconCell reset IconReset
-          , sortable (Just csvLmsDelete)    (i18nCell MsgTableLmsDelete)     $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete cutoff      -> del  ) -> ifIconCell del   IconRemoveUser
-          , sortable Nothing                (i18nCell MsgTableLmsStaff)      $ \(view $ _dbrOutput . _entityVal . _lmsUserStaff                -> staff) -> ifIconCell staff IconOK
-          , sortable (Just csvLmsResetTries)(i18nCell MsgTableLmsResetTries) $ \(view $ _dbrOutput . _entityVal . _lmsUserToResetTries         -> reset) -> ifIconCell reset IconResetTries
-          , sortable (Just csvLmsLock)      (i18nCell MsgTableLmsLock)       $ \(view $ _dbrOutput . _entityVal . _lmsUserToLock               -> lock ) -> ifIconCell lock  IconLocked
-          ]
-        dbtSorting = Map.fromList
-          [ (csvLmsIdent      , SortColumn (E.^. LmsUserIdent))
-          , (csvLmsPin        , SortColumn (E.^. LmsUserPin))
-          , (csvLmsResetPin   , SortColumn (E.^. LmsUserResetPin))
-          , (csvLmsDelete     , SortColumn (lmsUserToDeleteExpr cutoff))
-          -- , (csvLmsStaff   , E.false) -- currently always false
-          , (csvLmsResetTries , SortColumn lmsUserToResetTriesExpr)
-          , (csvLmsLock       , SortColumn lmsUserToLockExpr)
-          ]
-        dbtFilter = Map.fromList
-          [ (csvLmsIdent    , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsUserIdent ))
-          , (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast                      (E.^. LmsUserResetPin))
-          ]
-        dbtFilterUI mPrev = mconcat
-          [ prismAForm (singletonFilter csvLmsIdent    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
-          , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift boolField') (fslI MsgTableLmsResetPin)
-          ]
-        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
-        dbtParams = def
-        dbtIdent :: Text
-        dbtIdent = "lms-user"
-        dbtCsvEncode = Just DBTCsvEncode {..}
-          where
-            dbtCsvExportForm   = pure ()
-            dbtCsvNoExportData = Just id
-            dbtCsvExampleData  = Nothing
-            dbtCsvHeader       = const $ return lmsUserTableCsvHeader
-            dbtCsvDoEncode ()  = C.map (doEncode' . view _2)
-            doEncode' = LmsUserTableCsv
-              <$> view (_dbrOutput . _entityVal . _lmsUserIdent)
-              <*> view (_dbrOutput . _entityVal . _lmsUserPin)
-              <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
-              <*> view (_dbrOutput . _entityVal . _lmsUserToDelete cutoff . _lmsBool)
-              <*> view (_dbrOutput . _entityVal . to lmsUserStaff         . _lmsBool)
-              <*> view (_dbrOutput . _entityVal . to lmsUserToResetTries  . _lmsBool)
-              <*> view (_dbrOutput . _entityVal . to lmsUserToLock        . _lmsBool)
-
-        dbtCsvDecode = Nothing
-        dbtExtraReps = []
-
-    userDBTableValidator = def
-      & defaultSorting [SortAscBy csvLmsIdent]
-  dbTable userDBTableValidator userDBTable
-
-getQidCutoff ::  SchoolId -> QualificationShorthand -> DB (QualificationId, UTCTime)
-getQidCutoff sid qsh = do
-  Entity{entityKey = qid, entityVal = Qualification{qualificationAuditDuration=auditDur}} <- getBy404 $ SchoolQualificationShort sid qsh
-  now <- liftIO getCurrentTime
-  let cutoff = lmsDeletionDate now auditDur
-  return (qid, cutoff)
-
-getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsLearnersR sid qsh = do
-  (lmsTable, nr_orphans) <- runDB $ do
-    (qid, cutoff) <- getQidCutoff sid qsh
-    lmsTable <- view _2 <$> mkUserTable sid qsh qid cutoff
-    nr_orphans <- count [LmsOrphanQualification ==. qid]
-    return (lmsTable, nr_orphans)
-  when (nr_orphans > 0) $ addMessageI Warning $ MsgLmsOrphanNr nr_orphans
-  siteLayoutMsg MsgMenuLmsLearners $ do
-    setTitleI MsgMenuLmsLearners
-    lmsTable
-
-
--- selectOrphans :: QualificationId -> UTCTime -> DB [(LmsOrphanId, LmsIdent)]
-selectOrphans :: (MonadHandler m, HasAppSettings (HandlerSite m), BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend)
-              => Key Qualification -> UTCTime -> ReaderT backend m [(LmsOrphanId, LmsIdent)]
-selectOrphans qid now = do
-    lmsConf <- getsYesod $ view _appLmsConf
-    let cutoff_seen_first   = addLocalDays (negate $ lmsConf ^. _lmsOrphanDeletionDays) now
-        cutoff_deleted_last = addHours     (negate $ lmsConf ^. _lmsOrphanRepeatHours)  now
-        cutoff_seen_last    = cutoff_deleted_last
-        orphan_max_batch    =                        lmsConf ^. _lmsOrphanDeletionBatch
-    $(E.unValueN 2) <<$>> (Ex.select $ do
-        orv <- Ex.from $ Ex.table @LmsOrphan
-        Ex.where_ $ Ex.val qid                 E.==. orv Ex.^. LmsOrphanQualification
-            Ex.&&.  E.hasLetter                     (orv Ex.^. LmsOrphanIdent)                        -- do not delete LMS Test-users, FRADrive LMS Idents always contain at least one letter
-            Ex.&&.  Ex.val cutoff_seen_first   E.>=. orv Ex.^. LmsOrphanSeenFirst                     -- has been seen for while
-            Ex.&&.  Ex.val cutoff_seen_last    E.<=. orv Ex.^. LmsOrphanSeenLast                      -- was still seen recently
-            Ex.&&.  Ex.val cutoff_deleted_last E.>~. orv Ex.^. LmsOrphanDeletedLast                   -- not already recently deleted
-            Ex.&&. Ex.notExists (do                                                                   -- not currently used anywhere (LmsIdent share the namespace)
-                lusr <- Ex.from $ Ex.table @LmsUser
-                Ex.where_ $ lusr Ex.^. LmsUserIdent E.==. orv Ex.^.LmsOrphanIdent
-              )
-        Ex.orderBy [Ex.desc $ orv Ex.^. LmsOrphanDeletedLast, Ex.asc $ orv Ex.^. LmsOrphanSeenLast]   -- Note for PostgreSQL: DESC == DESC NULLS FIRST
-        Ex.limit orphan_max_batch
-        return (orv E.^. LmsOrphanId, orv E.^. LmsOrphanIdent)
-      )
-
-getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
-getLmsLearnersDirectR sid qsh = do
-  -- $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
-  (lms_users, orphans, cutoff, qshs) <- runDB $ do
-    (qid, cutoff) <- getQidCutoff sid qsh
-    qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
-    let qids = qid : (entityKey <$> qidsReuse)
-        qshs = qsh : (qualificationShorthand . entityVal <$> qidsReuse)
-    lms_users <- selectList [ LmsUserQualification <-. qids
-                            , LmsUserEnded ==. Nothing
-                            -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
-                            ] [Asc LmsUserStarted, Asc LmsUserIdent]
-    {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
-      Ex.select $ do
-        lmsuser <- Ex.from $ Ex.table @LmsUser
-        Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid
-            Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded)
-        pure $ LmsUserTableCsv
-          { csvLUTident    = lmsuser Ex.^. LmsUserIdent
-          , csvLUTpin      = lmsuser Ex.^. LmsUserPin
-          , csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin
-          , csvLUTdelete   = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus)
-          , csvLUTstaff    = LmsBool False
-          }
-      -}
-    now <- liftIO getCurrentTime
-    orphans <- selectOrphans qid now
-    updateWhere [LmsOrphanId <-. map fst orphans] [LmsOrphanDeletedLast =. Just now]
-    return (lms_users, orphans, cutoff, qshs)
-
-  LmsConf{..} <- getsYesod $ view _appLmsConf
-  let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
-      --csvRenderedHeader = lmsUserTableCsvHeader
-      --cvsRendered = CsvRendered {..}
-      csvRendered = toCsvRendered lmsUserTableCsvHeader $ (lmsUser2csv cutoff . entityVal <$> lms_users) <> (lmsUserDelete2csv . snd <$> orphans)
-      fmtOpts = (review csvPreset CsvPresetRFC)
-                    { csvIncludeHeader  = lmsDownloadHeader
-                    , csvDelimiter      = lmsDownloadDelimiter
-                    , csvUseCrLf        = lmsDownloadCrLf
-                    }
-      csvOpts = def { csvFormat = fmtOpts }
-  csvSheetName <- csvFilenameLmsUser qsh
-  let nr      = length lms_users
-      orv_nr  = length orphans
-      msg0 = "Success. LMS learners direct download file " <> csvSheetName <> " containing " <> tshow nr <> " rows for Qualifications " <> Text.intercalate ", " (ciOriginal <$> qshs)
-      msg1 = ". Orphaned LMS idents marked for deletion: " <> tshow orv_nr
-      msg  = if orv_nr > 0 then msg0 <> msg1 else msg1
-  $logInfoS "LMS" msg
-  addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
-  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
-    <* runDB (logInterface "LMS" (ciOriginal qsh) True (Just nr) "")
--- direct Download see:
--- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
-
-
-getLmsOrphansR :: SchoolId -> QualificationShorthand -> Handler Html
-getLmsOrphansR sid qsh = do
-  orvTable <- runDB $ do
-    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-    let
-      orvDBTable = DBTable{..}
-        where
-          queryOrphan  = id
-          -- resultOrphan = _dbrOutput . _entityVal -- would need explicit type to work
-          dbtSQLQuery orv = do
-            E.where_ $ orv E.^. LmsOrphanQualification E.==. E.val qid
-            return orv
-          dbtRowKey = (E.^. LmsOrphanId)
-          dbtProj = dbtProjId
-          dbtColonnade = dbColonnade $ mconcat
-            [ sortable (Just "ident")         (i18nCell MsgTableLmsIdent)        $ \(view $ _dbrOutput . _entityVal . _lmsOrphanIdent . _getLmsIdent -> lid) ->            textCell lid
-            , sortable (Just "seen-first")    (i18nCell MsgLmsOrphanSeenFirst)   $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenFirst    -> d)           ->            dateTimeCell d
-            , sortable (Just "seen-last")     (i18nCell MsgLmsOrphanSeenLast)    $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenLast     -> d)           ->            dateTimeCell d
-            , sortable (Just "deleted-last")  (i18nCell MsgLmsOrphanDeletedLast) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanDeletedLast  -> d)           -> cellMaybe  dateTimeCell d
-            , sortable (Just "status")        (i18nCell MsgTableLmsStatus)       $ \(view $ _dbrOutput . _entityVal . _lmsOrphanResultLast   -> s)           ->            lmsStateCell s
-            , sortable (Just "reason")        (i18nCell MsgLmsOrphanReason)      $ \(view $ _dbrOutput . _entityVal . _lmsOrphanReason       -> t)           -> cellMaybe  textCell t
-            ]
-          dbtSorting  = Map.fromList
-            [ ("ident"        , SortColumn (E.^. LmsOrphanIdent))
-            , ("seen-first"   , SortColumn (E.^. LmsOrphanSeenFirst))
-            , ("seen-last"    , SortColumn (E.^. LmsOrphanSeenLast))
-            , ("deleted-last" , SortColumn (E.^. LmsOrphanDeletedLast))
-            , ("status"       , SortColumn (E.^. LmsOrphanResultLast))
-            , ("reason"       , SortColumn (E.^. LmsOrphanReason))
-            ]
-          cachedNextOrphans = $(memcachedByHere) (Just $ Right $ 1 * diffMinute) ("cache-next-orphans" <> tshow qid) $ do
-            now <- liftIO getCurrentTime
-            next_orphans <- runDBRead $ selectOrphans qid now   -- only query next orphans when really needed; not sure how to formulate a proper sub-query here
-            -- addMessageI Info $ MsgLmsOrphanNr $ length next_orphans    -- debug
-            return $ map fst next_orphans
-          dbtFilter   = Map.fromList
-            [ ("ident"        , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsOrphanIdent))
-            , ("reason"       , FilterColumn $ E.mkContainsFilterWith          Just     (E.^. LmsOrphanReason))
-            , ("preview"      , FilterColumnHandler $ \case
-                (x:_)
-                  | x == tshow True -> do
-                      next_orphans <- cachedNextOrphans
-                      return $ \row -> (queryOrphan row E.^. LmsOrphanId) `E.in_`   E.valList next_orphans
-                  | x == tshow False -> do
-                      next_orphans <- cachedNextOrphans
-                      return $ \row -> (queryOrphan row E.^. LmsOrphanId) `E.notIn` E.valList next_orphans
-                _ -> return (const E.true)
-              )
-            ]
-          -- checkBoxTextField = convertField show (\case { t | t == show True -> True; _ -> False }) checkBoxField    -- UNNECESSARY hack to use FilterColumnHandler, which only works on [Text] criteria
-          dbtFilterUI mPrev = mconcat
-            [ -- prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgLmsOrphanPreviewFltr) -- NOTE: anticipated checkBoxTextField-hack not needed here
-              prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt boolField'  (fslI MsgLmsOrphanPreviewFltr)
-            , prismAForm (singletonFilter "reason"  . maybePrism _PathPiece) mPrev $ aopt textField   (fslI MsgLmsOrphanReason)
-            , prismAForm (singletonFilter "ident"   . maybePrism _PathPiece) mPrev $ aopt textField   (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
-            ]
-          dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
-          dbtParams = def
-          dbtIdent :: Text
-          dbtIdent = "lms-orphans"
-          dbtCsvEncode = noCsvEncode
-          dbtCsvDecode = Nothing
-          dbtExtraReps = []
-      orvDBTableValidator = def & defaultSorting [SortAscBy "seen-first", SortDescBy "deleted-last"]
-    snd <$> (dbTable orvDBTableValidator orvDBTable :: DB (Any, Widget))
-
-  LmsConf{..} <- getsYesod $ view _appLmsConf
-  siteLayoutMsg MsgLmsOrphans $ do
-    setTitleI MsgLmsOrphans
-    $(i18nWidgetFile "lms-orphans")

backend/src/Handler/MailCenter.hs

@@ -1,396 +0,0 @@
--- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Handler.MailCenter
-  ( getMailCenterR, postMailCenterR
-  , getMailHtmlR
-  , getMailPlainR
-  , getMailAttachmentR
-  ) where
-
-import Import
-
-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 qualified Data.Aeson as Aeson
-
-import Text.Blaze.Html (preEscapedToHtml)
--- import Text.Blaze.Html5 as H (html, body, pre, p, h1)
--- import Text.Blaze.Html.Renderer.String (renderHtml)
-
-import Numeric (readHex)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as LB
-
-
-import Handler.Utils
-
-
-data MCTableAction = MCActResendEmail
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-
-instance Universe MCTableAction
-instance Finite MCTableAction
-nullaryPathPiece ''MCTableAction $ camelToPathPiece' 2
-embedRenderMessage ''UniWorX ''MCTableAction id
-
-newtype MCTableActionData  = MCActResendEmailData UserEmail
-  deriving (Eq, Ord, Read, Show, Generic)
-
-
-resendMailTo :: (MonoFoldable mono, Element mono ~ SentMailId) => UserEmail -> mono -> Handler ()
-resendMailTo recv smids = do
-  (recvName, mails) <- runDBRead $ (,)
-    <$> (userDisplayName . entityVal <<$>> getByFilter ([UserEmail ==. recv] ||. [UserDisplayEmail ==. recv]))
-    <*> E.select (do
-          (sm :& smc) <- E.from $ E.table @SentMail `E.innerJoin` E.table @SentMailContent `E.on` (\(sm :& smc) -> sm E.^. SentMailContentRef E.==. smc E.^. SentMailContentId)
-          E.where_ $ sm E.^. SentMailId `E.in_` E.vals smids
-          return (sm, smc)
-        )
-  forM_ mails $ \(Entity {entityVal=SentMail{..}}, Entity{entityVal=SentMailContent{sentMailContentContent=content}}) -> do
-    let mailParts = getMailContent content
-        mailTo    = []
-        mailCc    = []
-        mailBcc   = [Address{addressName = recvName, addressEmail = ciOriginal recv}]
-        mailFrom  = error "Handler.MailCenter.resenMailTo: mailFrom not replaced by sendSimpleMail"  -- :: Address -- will be filled in later by sendSimpleMail
-        mailHeaders = toHeaders sentMailHeaders -- :: Headers -- keep as it was? Includes To/Cc/Bcc
-    sendSimpleMail Mail{..}
-
-
-type MCTableExpr =
-  (                   E.SqlExpr (Entity SentMail)
-    `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
-  )
-
-queryMail :: MCTableExpr -> E.SqlExpr (Entity SentMail)
-queryMail = $(sqlLOJproj 2 1)
-
-
-queryRecipient :: MCTableExpr -> E.SqlExpr (Maybe (Entity User))
-queryRecipient = $(sqlLOJproj 2 2)
-
-
-type MCTableData = DBRow (Entity SentMail, Maybe (Entity User))
-
-resultMail :: Lens' MCTableData (Entity SentMail)
-resultMail = _dbrOutput . _1
-
-resultRecipient :: Traversal' MCTableData (Entity User)
-resultRecipient = _dbrOutput . _2 . _Just
-
-
-mkMCTable :: DB (FormResult (MCTableActionData, Set SentMailId), Widget)
-mkMCTable = do
-  let
-    dbtSQLQuery :: MCTableExpr -> E.SqlQuery (E.SqlExpr (Entity SentMail), E.SqlExpr (Maybe (Entity User)))
-    dbtSQLQuery  (mail `E.LeftOuterJoin` recipient) = do
-      EL.on $ mail E.^. SentMailRecipient E.==. recipient E.?. UserId
-      return (mail, recipient)
-    dbtRowKey = queryMail >>> (E.^. SentMailId)
-    dbtProj = dbtProjId
-    dbtColonnade = mconcat
-      [ -- dbSelect (applying _2) id (return . view (resultMail . _entityKey))
-        sortable (Just "sent")      (i18nCell MsgPrintJobCreated)       $ \(   view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t
-      , sortable (Just "recipient") (i18nCell MsgPrintRecipient)        $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
-      , sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) ->
-          let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
-              linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject
-          in anchorCellM (MailHtmlR <$> encrypt k) linkWgt
-      -- , 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 = Map.fromList
-      [ ("sent"      , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
-      , ("recipient" , sortUserNameBareM queryRecipient)
-      ]
-    dbtFilter = Map.fromList
-      [ ("sentTo"    , FilterColumn . E.mkDayFilterTo                        $ views (to queryMail)        (E.^. SentMailSentAt))
-      , ("sentFrom"  , FilterColumn . E.mkDayFilterFrom                      $ 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)))
-      , ("content"   , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
-          body <- E.from $ E.table @SentMailContent
-          E.where_ $ body E.^. SentMailContentId E.==. queryMail row E.^. SentMailContentRef
-                E.&&. E.mailContentContains (body E.^. SentMailContentContent) (E.val criterion)
-        )
-      ]
-    dbtFilterUI mPrev = mconcat
-      [ prismAForm (singletonFilter "sentTo"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgTableFilterSentBefore)
-      , prismAForm (singletonFilter "sentFrom"  . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgTableFilterSentAfter)
-      , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
-      , prismAForm (singletonFilter "subject"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommSubject    & setTooltip MsgTableFilterCommaPlusShort)
-      -- , prismAForm (singletonFilter "regex"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommSubject    )
-      , prismAForm (singletonFilter "content"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommContent) --    & setTooltip MsgCommContentSearch)
-      ]
-    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
-    dbtIdent :: Text
-    dbtIdent = "sent-mail"
-    dbtCsvEncode = noCsvEncode
-    dbtCsvDecode = Nothing
-    dbtExtraReps = []
-    dbtParams = DBParamsForm
-      { dbParamsFormMethod = POST
-      , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
-      , dbParamsFormAttrs  = []
-      , dbParamsFormSubmit = FormSubmit
-      , dbParamsFormAdditional
-          = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
-                acts = mconcat
-                  [ singletonMap MCActResendEmail $ MCActResendEmailData
-                      <$> areq (emailField & cfStrip & cfCI) (fslI MsgMCActResendEmail & setTooltip MsgMCActResendEmailTooltip) Nothing
-                  ]
-             in renderAForm FormStandard
-               $  (, mempty) . First . Just
-              <$> multiActionA acts (fslI MsgTableAction) Nothing
-      , dbParamsFormEvaluate = liftHandler . runFormPost
-      , dbParamsFormResult   = id
-      , dbParamsFormIdent    = def
-      }
-    postprocess :: FormResult (First MCTableActionData, DBFormResult SentMailId Bool MCTableData)
-                -> FormResult (      MCTableActionData, Set SentMailId)
-    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 [SortDescBy "sent"]
-  over _1 postprocess <$> dbTable psValidator DBTable{..}
-
-getMailCenterR,  postMailCenterR :: Handler Html
-getMailCenterR = postMailCenterR
-postMailCenterR = do
-  (mcRes, mcTable) <- runDB mkMCTable
-  formResult mcRes $ \case
-    (MCActResendEmailData recv, smIds) -> do
-      resendMailTo recv smIds
-      addMessageI (bool Success Error $ null smIds) $ MsgMCActResendEmailInfo (Set.size smIds) (ciOriginal recv)
-      reloadKeepGetParams MailCenterR
-  siteLayoutMsg MsgMenuMailCenter $ do
-    setTitleI MsgMenuMailCenter
-    $(widgetFile "mail-center")
-
-
-typePDF :: ContentType
-typePDF = "application/pdf"
-
-getMailAttachmentR :: CryptoUUIDSentMail -> Text -> Handler TypedContent
-getMailAttachmentR cusm attdisp = do
-  smid <- decrypt cusm
-  (sm,cn) <- runDBRead $ do
-    sm <- get404 smid
-    cn <- get404 $ sm ^. _sentMailContentRef
-    return (sm,cn)
-  let mcontent = getMailContent (sentMailContentContent cn)
-      getAttm alts = case selectAlternative [typePDF] alts of
-        (Just Part{partContent=PartContent (LB.toStrict -> pc), partDisposition=AttachmentDisposition t}) -- partType=pt,
-          | t == attdisp
-            -> Just pc
-        _ -> Nothing
-      attm = firstJust getAttm mcontent
-  case attm of
-    (Just pc) -> sendByteStringAsFile (T.unpack attdisp) pc $ sm ^. _sentMailSentAt
-    _              -> notFound
-
-getMailHtmlR  :: CryptoUUIDSentMail -> Handler Html
-getMailHtmlR  = handleMailShow (SomeMsgs [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml])  [typeHtml,typePlain]
-
-getMailPlainR :: CryptoUUIDSentMail -> Handler Html
-getMailPlainR = handleMailShow (SomeMsgs [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailPlain]) [typePlain,typeHtml]
-
-handleMailShow :: _ -> [ContentType] -> CryptoUUIDSentMail -> Handler Html
-handleMailShow hdr prefTypes cusm = do
-  smid <- decrypt cusm
-  (sm,cn) <- runDBRead $ do
-    sm <- get404 smid
-    cn <- get404 $ sm ^. _sentMailContentRef
-    return (sm,cn)
-  siteLayout' Nothing $ do
-    setTitleI hdr
-    let mcontent = getMailContent (sentMailContentContent cn)
-        getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
-        mparts = reorderParts $ mapMaybe (selectAlternative prefTypes) mcontent
-    [whamlet|
-      <section>
-        <dl .deflist>
-          <dt .deflist__dt>
-            _{MsgPrintJobCreated}
-          <dd .deflist__dd>
-            ^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
-          $maybe usr <- sm ^. _sentMailRecipient
-            <dt .deflist__dt>
-              _{MsgPrintRecipient}
-            <dd .deflist__dd>
-              ^{userIdWidget usr}
-          $maybe r <- getHeader "To"
-            <dt .deflist__dt>
-              To
-            <dd .deflist__dd>
-              #{decodeEncodedWord r}
-          $maybe r <- getHeader "Cc"
-            <dt .deflist__dt>
-              Cc
-            <dd .deflist__dd>
-              #{decodeEncodedWord r}
-          $maybe r <- getHeader "From"
-            <dt .deflist__dt>
-              From
-            <dd .deflist__dd>
-              #{decodeEncodedWord r}
-          $maybe r <- getHeader "Subject"
-            <dt .deflist__dt>
-              _{MsgCommSubject}
-            <dd .deflist__dd>
-              #{decodeEncodedWord r}
-
-      <section>
-        $forall pt <- mparts
-          ^{part2widget cusm pt}
-    |]
-      -- Include for Debugging:
-      -- <section>
-      --   <h2>Debugging
-      --   <p>
-      --     ^{jsonWidget (sm ^. _sentMailHeaders)}
-      --   <p>
-      --     ^{jsonWidget (sentMailContentContent cn)} -- content fields needs decoding of base64 to make sense here
-
-selectAlternative :: [ContentType] -> Alternatives -> Maybe Part
-selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
-  where
-    aux ts@(ct:_) (pt:ps)
-      | ct == partType pt = Just pt
-      | otherwise         = aux ts ps
-    aux (_:ts) []         = aux ts allAlts
-    aux []     (pt:_)     = Just pt
-    aux _      []         = Nothing
-
-reorderParts :: [Part] -> [Part]
-reorderParts = sortBy pOrder
-  where
-    pOrder Part{partDisposition=d1} Part{partDisposition=d2} = dispoOrder d1 d2
-
-    dispoOrder DefaultDisposition DefaultDisposition                 = EQ
-    dispoOrder DefaultDisposition _                                  = LT
-    dispoOrder _ DefaultDisposition                                  = GT
-    dispoOrder (InlineDisposition t1) (InlineDisposition t2)         = compare t1 t2
-    dispoOrder (InlineDisposition _) _                               = LT
-    dispoOrder _ (InlineDisposition _)                               = GT
-    dispoOrder (AttachmentDisposition t1) (AttachmentDisposition t2) = compare t1 t2
-
-disposition2widget :: Disposition -> Widget
-disposition2widget (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
-disposition2widget (InlineDisposition     n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
-disposition2widget  DefaultDisposition       = mempty
-
-part2widget :: CryptoUUIDSentMail -> Part -> Widget
-part2widget cusm Part{partContent=NestedParts ps} =
-  [whamlet|
-      $forall p <- ps
-        ^{part2widget cusm p}
-  |]
-part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
-    [whamlet|
-      <section>
-        ^{disposition2widget dispo}
-        ^{showBody}
-      ^{showPass}
-    |]
-  where
-    showBody
-      | pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plainTextToHtml $ decodeUtf8 pc
-      | pt == decodeUtf8 typeHtml  = toWidget $ preEscapedToHtml $ plainHtmlToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
-      | pt == decodeUtf8 typeJson  =
-          let jw :: Aeson.Value -> Widget = jsonWidget
-          in  either str2widget jw $ Aeson.eitherDecodeStrict' pc
-      | pt == decodeUtf8 typePDF
-      , AttachmentDisposition t <- dispo
-        = [whamlet|<a href=@{MailAttachmentR cusm t}>#{t}|]
-      | otherwise = [whamlet|FRADrive cannot decode email parts of type #{pt} yet.|]
-    showPass
-      | pt == decodeUtf8 typePlain
-      , let cw = T.words $ decodeUtf8 pc
-      , Just name <- listBracket ("Inhaber","Gültig") cw                               -- heursitic for dirving licence renewal letters only; improve
-                <|>  listBracket ("Licensee","Valid") cw
-      = let sdn = T.filter (/= '*') (T.unwords $ dropWhile (":"==) name) in
-        liftHandler (runDBRead $ getByFilter [UserDisplayName ==. sdn]) >>= \case
-          Nothing -> mempty -- DEBUG: [whamlet|<h2>Not found: #{sdn}|]
-          Just Entity{entityVal = u@User{userPinPassword=mbpw}} ->
-            [whamlet|
-              <section>
-                $maybe pw <- mbpw
-                  <details>
-                    <summary>
-                      _{MsgAdminUserPinPassword}
-                    <p>
-                      <dl .deflist>
-                        <dt .deflist__dt>
-                          ^{userWidget u}
-                        <dd .deflist__dd>
-                          <b>
-                            #{pw}
-                    <p>
-                      _{MsgAdminUserPinPassNotIncluded}
-                $nothing
-                  _{MsgAdminUserNoPassword}
-            |]
-      | otherwise = mempty
-
-------------------------------
--- Decode MIME Encoded Word
-
--- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047.
-decodeEncodedWord :: Text -> Text
-decodeEncodedWord tinp
-  | (pl, T.drop 2 -> cf) <- T.breakOn "=?" tinp
-  , (cw, T.drop 2 -> rm) <- T.breakOn "?=" cf
-  , notNull cw
-    = pl <> decodeEncodedWordHeader cw <> decodeEncodedWord rm
-  | otherwise
-    = tinp
-
-decodeEncodedWordHeader :: Text -> Text
-decodeEncodedWordHeader tinp
-  | [enc, bin, cw] <- T.splitOn "?" tinp
-  , "utf-8" == T.toLower enc
-  , "Q"     == T.toUpper bin      -- Quoted Printable Text
-    = decEncWrdUtf8Q cw
-  -- TODO: add more decoders for other possible encodings here, but "=?utf-8?Q?..?=" is the only one used by Network.Mail.Mime at the moment
-  | otherwise
-    = tinp
-
-decEncWrdUtf8Q :: Text -> Text
-decEncWrdUtf8Q tinp
-  | Right ok <- TE.decodeUtf8' $ decWds tinp
-    = ok
-  | otherwise
-    = tinp
-  where
-    decWds :: Text -> S.ByteString
-    decWds t
-      | (h:tl) <- T.splitOn "=" t
-        = mconcat $ TE.encodeUtf8 h : map deco tl
-      | otherwise
-        = TE.encodeUtf8 t
-
-    deco :: Text -> S.ByteString
-    deco w
-      | (c,r) <- T.splitAt 2 w
-      , [(v,"")] <- readHex $ T.unpack c
-        = S.cons v $ TE.encodeUtf8 r
-      | otherwise
-        = TE.encodeUtf8 w

backend/src/Handler/Qualification/Edit.hs

@@ -1,115 +0,0 @@
--- SPDX-FileCopyrightText: 2025 Steffen Jost <S.Jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
-{-# LANGUAGE TypeApplications #-}
-
-module Handler.Qualification.Edit
-  ( getQualificationNewR,  postQualificationNewR
-  , getQualificationEditR, postQualificationEditR
-  )
-  where
-
-import Import
-
-import qualified Data.Text as Text
-import qualified Control.Monad.State.Class as State
-
-import Handler.Utils
--- import           Database.Esqueleto.Experimental ((:&)(..))
--- import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
-
-
-getQualificationNewR,  postQualificationNewR :: SchoolId -> Handler Html
-getQualificationNewR = postQualificationNewR
-postQualificationNewR ssh = handleQualificationEdit ssh Nothing
-
-getQualificationEditR,  postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html
-getQualificationEditR = postQualificationEditR
-postQualificationEditR ssh qsh = do
-  qent <- runDBRead $ getBy404 $ SchoolQualificationShort ssh qsh
-  handleQualificationEdit ssh $ Just qent
-
-
-mkQualificationForm :: SchoolId -> Maybe Qualification -> Form Qualification
-mkQualificationForm ssh templ = identifyForm FIDQualificationEdit . validateForm (validateQualificationEdit ssh) $ \html ->
-    flip (renderAForm FormStandard) html $ reorderedQualification
-      <$> areq hiddenField "" (Just ssh)                                                                                                                --  1 ->  1
-      <*> areq ciField                                      (fslI MsgQualificationShort)                  (qualificationShorthand           <$> templ)  --  2 ->  2
-      <*> areq ciField                                      (fslI MsgQualificationName)                   (qualificationName                <$> templ)  --  3 ->  3
-      <*> aopt htmlField                                    (fslI MsgQualificationDescription)            (qualificationDescription         <$> templ)  --  4 ->  4
-      <*> aopt_natFieldI                                          MsgQualificationValidDuration           (qualificationValidDuration       <$> templ)  --  5 ->  5
-      <*> aopt calendarDiffDaysField                        (fslI MsgQualificationRefreshWithin &
-                                                      setTooltip  MsgQualificationRefreshWithinTooltip)   (qualificationRefreshWithin       <$> templ)  --  6 ->  7
-
-      <*> areq checkBoxField                                (fslI MsgQualificationElearningStart)         (qualificationElearningStart      <$> templ)  --  7 ->  9
-      <*> aopt calendarDiffDaysField                        (fslI MsgQualificationRefreshReminder &
-                                                      setTooltip  MsgQualificationRefreshReminderTooltip) (qualificationRefreshReminder     <$> templ)  --  8 -> 8
-      <*> areq checkBoxField                                (fslI MsgQualificationExpiryNotification)     (qualificationExpiryNotification  <$> templ)  --  9 -> 13
-      <*> areq_natFieldI                                          MsgQualificationAuditDuration           (qualificationAuditDuration       <$> templ)  -- 10 -> 6
-      <*> areq checkBoxField                                (fslI MsgQualificationElearningRenew)         (qualificationElearningRenews     <$> templ)  -- 11 -> 10
-      <*> aopt_natFieldI                                          MsgQualificationElearningLimit          (qualificationElearningLimit      <$> templ)  -- 12 -> 11
-      <*> aopt qualificationField                           (fslI MsgTableQualificationLmsReuses &
-                                                      setTooltip  MsgTableQualificationLmsReusesTooltip)  (qualificationLmsReuses           <$> templ)  -- 13 -> 12
-      <*> aopt avsLicenceField                              (fslI MsgQualificationAvsLicence &
-                                                  setTooltip MsgTableQualificationIsAvsLicenceTooltip)    (qualificationAvsLicence          <$> templ)  -- 14 -> 14
-      <*> aopt textField                                    (fslI MsgQualificationSapId &
-                                                  setTooltip MsgTableQualificationSapExportTooltip)       (qualificationSapId               <$> templ)  -- 15 -> 15
-  where
-    avsLicenceField :: Field Handler AvsLicence
-    avsLicenceField = selectFieldList [ (Text.singleton $ licence2char lic, lic) | lic <- universeF, lic /= AvsNoLicence ]
-
-    aopt_natFieldI msg = aopt (natFieldI $ SomeMessages " " [SomeMessage msg, SomeMessage MsgMustBePositive]) (fslI msg)
-    areq_natFieldI msg = areq (natFieldI $ SomeMessages " " [SomeMessage msg, SomeMessage MsgMustBePositive]) (fslI msg)
-                                       -- [ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15]
-    reorderedQualification = $(permuteFun [ 1, 2, 3, 4, 5,10, 6, 8, 7,11,12,13, 9,14,15]) Qualification --  == inversePermutation [1,2,3,4,5,7,9,8,13,6,10,11,12,14,15]
-
-validateQualificationEdit :: SchoolId -> FormValidator Qualification Handler ()
-validateQualificationEdit ssh = do
-    canonise
-    Qualification{..} <- State.get
-    guardValidation MsgQualFormErrorSshMismatch             $ qualificationSchool == ssh
-    guardValidation MsgLmsErrorNoRefreshElearning           $ not qualificationElearningStart || isJust qualificationRefreshWithin
-    guardValidation MsgLmsErrorNoRenewElearning             $ not qualificationElearningStart || isJust qualificationValidDuration
-    when (isJust qualificationLmsReuses) $
-      liftHandler $ addMessageI Info MsgQualificationAuditDurationReuseInfo
-  where
-    canonise = do --  i.e. map Just 0 to Nothing
-      Qualification{..} <- State.get
-      -- canonisation, i.e. map Just 0 to Nothing
-      when (qualificationRefreshWithin   == Just mempty) $ State.modify $ set _qualificationRefreshWithin   Nothing
-      when (qualificationRefreshReminder == Just mempty) $ State.modify $ set _qualificationRefreshReminder Nothing
-      when (qualificationValidDuration   == Just      0) $ State.modify $ set _qualificationValidDuration   Nothing
-      when (qualificationElearningLimit  == Just      0) $ State.modify $ set _qualificationElearningLimit  Nothing
-
-
-
-handleQualificationEdit :: SchoolId -> Maybe (Entity Qualification) -> Handler Html
-handleQualificationEdit ssh templ = do
-  ((qRes, qWgt), qEnc) <- runFormPost $ mkQualificationForm ssh $ entityVal <$> templ
-  let qForm = wrapForm qWgt def
-                { formEncoding = qEnc
-                }
-  formResult qRes $ \resQuali -> do
-    uniqViolation <- runDB $ case templ of
-      Just Entity{entityKey=qid} -> replaceUnique qid resQuali                                -- edit old qualification
-      _ -> maybeM (checkUnique resQuali) (const $ return Nothing) (insertUnique resQuali)     -- insert new qualification
-    case uniqViolation of
-      Just (SchoolQualificationShort _ nconflict) -> addMessageI Error $ MsgQualFormErrorDuplShort $ ciOriginal nconflict
-      Just (SchoolQualificationName  _ nconflict) -> addMessageI Error $ MsgQualFormErrorDuplName  $ ciOriginal nconflict
-      Nothing -> do
-        let qshort = qualificationShorthand resQuali
-            qmsg   = if isNothing templ then MsgQualificationCreated else MsgQualificationEdit
-        addMessageI Success $ qmsg $ ciOriginal qshort
-        redirect $ QualificationR ssh qshort
-  let heading = bool MsgMenuQualificationNew MsgMenuQualificationEdit $ isJust templ
-  siteLayoutMsg heading $ do
-    setTitleI heading
-    [whamlet|
-      <p>
-        ^{qForm}
-      $maybe _ <- templ
-        <p>
-          _{MsgQualificationEditNote}
-    |]

backend/src/Handler/School/DayTasks.hs

@@ -1,877 +0,0 @@
-
--- SPDX-FileCopyrightText: 2024-2025 Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
-
-module Handler.School.DayTasks
-  ( getSchoolDayR, postSchoolDayR
-  , getSchoolDayCheckR
-  ) where
-
-import Import
-
-import Handler.Utils
-import Handler.Utils.Company
--- import Handler.Utils.Occurrences
-import Handler.Utils.Avs
-import Handler.Utils.Course.Cache
-
-import qualified Data.Set  as Set
-import qualified Data.Map  as Map
-import qualified Data.Text as Text
-
--- import Database.Persist.Sql (updateWhereCount)
-import           Database.Esqueleto.Experimental ((:&)(..))
-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
-
-
--- | 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)
-
--- instance Universe DailyTableAction
--- instance Finite DailyTableAction
--- nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2
--- embedRenderMessage ''UniWorX ''DailyTableAction id
-
--- data DailyTableActionData = DailyActDummyData
---   deriving (Eq, Ord, Read, Show, Generic)
-
-
-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.LeftOuterJoin`   E.SqlExpr (Maybe (Entity UserAvs))
-    `E.LeftOuterJoin`   E.SqlExpr (Maybe (Entity UserDay))
-    `E.LeftOuterJoin`   E.SqlExpr (Maybe (Entity TutorialParticipantDay))
-  )
-
-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 (Maybe (Entity UserDay))
-  , E.SqlExpr (Maybe (Entity TutorialParticipantDay))
-  , 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)
-  , Maybe (Entity UserDay)
-  , Maybe (Entity TutorialParticipantDay)
-  , E.Value (Maybe CompanyId)
-  , 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 [])
-
-
-queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course)
-queryCourse = $(sqlMIXproj' ''DailyTableExpr 1)
-
-queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial)
-queryTutorial = $(sqlMIXproj' ''DailyTableExpr 2)
-
-queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant)
-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)
-
-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
-
-resultTutorial :: Lens' DailyTableData (Entity Tutorial)
-resultTutorial = _dbrOutput . _2
-
-resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant)
-resultParticipant = _dbrOutput . _3
-
-resultUser :: Lens' DailyTableData (Entity User)
-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 . _8 . _unValue . _Just
-
-resultCourseQualis :: Traversal' DailyTableData [QualificationId]
-resultCourseQualis = _dbrOutput . _9 . _unValue . _Just
-
-
-instance HasEntity DailyTableData User where
-  hasEntity = resultUser
-
-instance HasUser DailyTableData where
-  hasUser = resultUser . _entityVal
-
--- see colRatedField' for an example of formCell usage
-
-drivingPermitField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserDrivingPermit
-drivingPermitField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite
-
-eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserEyeExam
-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
-  (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
-
-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
-  (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" & 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: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" & addClass' "uwx-narrow") (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","min-width:12em")]) <$>
-  formCell id
-  (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 sid cid tid)) (fsUniq mkUnique "note-tutorial") (Just note)
-  )
-
-suggsParticipantNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
-suggsParticipantNote sid cid tid = do
-  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 $
-        ( 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
-
-suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
-suggsAttendanceNote sid cid 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 $
-        ( 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 (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
-    pure $ mkOptionListCacheable $ mkOptionText <$> nubOrd suggs -- NOTE: datalist does not work on textarea inputs
-  pure $ mkOptionListFromCacheable ol
-
-
-colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
-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","min-width:12em")]) <$>
-  formCell id
-  (views (resultParticipant . _entityKey) return)
-  (\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) . 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 :: 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)))
--- 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 -> 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 third 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 -> 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
-      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 MsgTableCourse)     $ \(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 . snd) $ 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 $ snd <$> 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-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
-                  result
-                    | primComp /= bookComp
-                    , Just (unCompanyKey -> csh) <- primComp
-                      = cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|]
-                             (Just IconCompany) True)
-                      <> spacerCell
-                      <> bookLink
-                    | otherwise = bookLink
-              in result
-          -- , sortable (Just "booking-firm") (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 -- maybe just use iconCompanyWarning instead of modal?
-          --                 [whamlet|
-          --                   <h2>
-          --                     ^{userWidget row}
-          --                   <p>
-          --                     _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}
-          --                 |]
-          --                 ))
-          --           | otherwise = bookLink
-          --     in result
-          , maybeEmpty dcrs $ \DayCheckResults{..} ->
-            sortable (Just "check-fail") (timeCell dcrTimestamp) $ \(view $ resultParticipant . _entityKey -> tpid) ->
-              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
-          , colParticipantEyeExamField
-          , colParticipantPermitField
-          , colParticipantNoteField
-          , colAttendanceField     dday
-          , colAttendanceNoteField dday
-          , 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
-          -- , 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-firm"   , 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))
-          -- , ("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
-          , fltrUserMatriclenr  queryUser
-          , ("course"       , FilterColumn . E.mkContainsFilter $ queryCourse   >>> (E.^. CourseName))
-          , ("tutorial"     , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
-          , ("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 "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
-          ]
-        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{..}
-      over _2 Just <$> dbTable psValidator DBTable{..}
-
-
-getSchoolDayR,  postSchoolDayR :: SchoolId -> Day -> Handler Html
-getSchoolDayR = postSchoolDayR
-postSchoolDayR ssh nd = do
-  isAdmin <- hasReadAccessTo AdminR
-  dday <- formatTime SelFormatDate 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
-            }
-  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
-      -- 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.
-    memcachedByInvalidate (CacheKeyTutorialCheckResults ssh nd) $ Proxy @DayCheckResults
-    addMessageI Success $ MsgTutorialParticipantsDayEdits dday
-    redirect $ SchoolR ssh $ SchoolDayR nd
-
-  siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
-    let consistencyBtn = btnModal MsgMenuSchoolDayCheck [BCIsButton, BCDefault] (Left $ SomeRoute $ SchoolR ssh $ SchoolDayCheckR nd)
-    setTitleI (MsgMenuSchoolDay ssh dday)
-    $(i18nWidgetFile "day-view")
-
-
--- | A wrapper for several check results on tutorial participants
-data DayCheckResult = DayCheckResult
-      { dcAvsKnown      :: Bool
-      , dcApronAccess   :: Bool
-      , dcBookingFirmOk :: Bool
-      , dcEyeFitsPermit :: Maybe Bool
-      }
-  deriving (Eq, Show, Generic, Binary)
-
-data DayCheckResults = DayCheckResults
-      { dcrTimestamp :: UTCTime
-      , dcrResults   :: Map TutorialParticipantId DayCheckResult
-      }
-  deriving (Show, Generic, Binary)
-
--- | True iff there is no problem at all
-dcrIsOk :: DayCheckResult -> Bool
-dcrIsOk (DayCheckResult True True True (Just 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
-
--- | Possible outcomes for DayCheckResult
-dcrMessages :: [SomeMessage UniWorX]
-dcrMessages = [ SomeMessage   MsgAvsPersonSearchEmpty
-              , SomeMessage   MsgAvsNoApronCard
-              , SomeMessage $ MsgAvsNoCompanyCard Nothing
-              , SomeMessage   MsgCheckEyePermitMissing
-              , SomeMessage   MsgCheckEyePermitIncompatible
-              ]
-
--- | 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) =
-    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
-  now <- liftIO getCurrentTime
-  let nowaday = utctDay now
-  dday <- formatTime SelFormatDate nd
-
-  (tuts, parts_avs, examProblemsTbl) <- runDB $ 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)
-            `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 (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)
-      )
-    -- 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)
-    -- check for double examiners
-    examProblemsTbl <- mkExamProblemsTable ssh nd
-    return (tuts, parts_avs, examProblemsTbl)
-  let getApi :: ParticipantCheckData -> Set AvsPersonId
-      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
-      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
-            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) -- 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
-            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
-    [whamlet|
-      <section>
-        <h2>
-          _{MsgMenuSchoolDay ssh dday}
-        <p>
-          $if Map.null badTutPartMap
-            _{MsgNoProblem}.
-          $else
-            <dl .deflist.profile-dl>
-              $forall (tid,badis)  <- Map.toList badTutPartMap
-                <dt .deflist__dt>
-                  #{maybe "???" fst (Map.lookup tid tuts)}
-                <dd .deflist__dd>
-                  <ul>
-                    $forall ((_udn,pid),pcd) <- Map.toList badis
-                      <li>
-                        ^{mkBaddieWgt pid pcd}
-        <section>
-          <p>
-            <h4 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
-              _{MsgPossibleCheckResults}
-            <p>
-              <ul>
-                $forall msg <- dcrMessages
-                  <li>_{msg}
-            <p>
-              _{MsgAvsUpdateDayCheck}
-      <section>
-        ^{maybeTable' MsgExamProblemReoccurrence (Just MsgExamNoProblemReoccurrence) Nothing examProblemsTbl}
-      <section>
-        ^{linkButton mempty (i18n MsgBtnCloseReload) [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))}
-    |]
-
-
-type TblExamPrbsExpr = (                E.SqlExpr (Entity Course)
-                      `E.InnerJoin`     E.SqlExpr (Entity Exam)
-                      `E.InnerJoin`     E.SqlExpr (Entity ExamRegistration)
-                      `E.InnerJoin`     E.SqlExpr (Entity ExamOccurrence)
-                      `E.InnerJoin`     E.SqlExpr (Entity User)
-                      `E.InnerJoin`     E.SqlExpr (Entity User)
-                    )
-type TblExamPrbsData = DBRow (Entity Course, Entity Exam, Entity ExamRegistration, Entity ExamOccurrence, Entity User, Entity User)
-
--- | Table listing double examiner problems for a given school and day
-mkExamProblemsTable :: SchoolId -> Day -> DB (Bool, Widget)
-mkExamProblemsTable =
-  let dbtIdent = "exams-user" :: Text
-      dbtStyle = def
-      dbtSQLQuery' exOccs (crs `E.InnerJoin` exm `E.InnerJoin` reg `E.InnerJoin` occ `E.InnerJoin` usr `E.InnerJoin` xmr) = do
-        EL.on $ xmr E.^. UserId                     E.=?. occ E.^. ExamOccurrenceExaminer
-        EL.on $ usr E.^. UserId                     E.==. reg E.^. ExamRegistrationUser
-        EL.on $ occ E.^. ExamOccurrenceId           E.=?. reg E.^. ExamRegistrationOccurrence
-        EL.on $ exm E.^. ExamId                     E.==. reg E.^. ExamRegistrationExam
-        EL.on $ exm E.^. ExamCourse                 E.==. crs E.^. CourseId
-        E.where_ $ occ E.^. ExamOccurrenceId `E.in_` E.vals exOccs
-            E.&&.  E.exists (do
-                altReg :& altOcc <- E.from $ E.table @ExamRegistration `E.innerJoin` E.table @ExamOccurrence
-                                    `E.on` (\(altReg :& altOcc) -> altReg E.^. ExamRegistrationOccurrence E.?=. altOcc E.^. ExamOccurrenceId)
-                E.where_ $ altReg E.^. ExamRegistrationUser   E.==. reg E.^. ExamRegistrationUser
-                    E.&&.  altReg E.^. ExamRegistrationId     E.!=. reg E.^. ExamRegistrationId
-                    E.&&.  altOcc E.^. ExamOccurrenceExaminer E.==. occ E.^. ExamOccurrenceExaminer
-                    E.&&.  altOcc E.^. ExamOccurrenceId       E.!=. occ E.^. ExamOccurrenceId
-              )
-        return (crs,exm,reg,occ,usr,xmr)
-      queryExmCourse    :: TblExamPrbsExpr -> E.SqlExpr (Entity Course)
-      queryExmCourse    = $(sqlIJproj 6 1)
-      queryExam         :: TblExamPrbsExpr -> E.SqlExpr (Entity Exam)
-      queryExam         = $(sqlIJproj 6 2)
-      queryRegistration :: TblExamPrbsExpr -> E.SqlExpr (Entity ExamRegistration)
-      queryRegistration = $(sqlIJproj 6 3)
-      queryOccurrence   :: TblExamPrbsExpr -> E.SqlExpr (Entity ExamOccurrence)
-      queryOccurrence   = $(sqlIJproj 6 4)
-      queryTestee       :: TblExamPrbsExpr -> E.SqlExpr (Entity User)
-      queryTestee       = $(sqlIJproj 6 5)
-      queryExaminer     :: TblExamPrbsExpr -> E.SqlExpr (Entity User)
-      queryExaminer     = $(sqlIJproj 6 6)
-      resultExmCourse     :: Lens' TblExamPrbsData (Entity Course)
-      resultExmCourse     = _dbrOutput . _1
-      resultExam          :: Lens' TblExamPrbsData (Entity Exam)
-      resultExam          = _dbrOutput . _2
-      resultRegistration  :: Lens' TblExamPrbsData (Entity ExamRegistration)
-      resultRegistration  = _dbrOutput . _3
-      resultOccurrence    :: Lens' TblExamPrbsData (Entity ExamOccurrence)
-      resultOccurrence    = _dbrOutput . _4
-      resultTestee        :: Lens' TblExamPrbsData (Entity User)
-      resultTestee        = _dbrOutput . _5
-      resultExaminer      :: Lens' TblExamPrbsData (Entity User)
-      resultExaminer      = _dbrOutput . _6
-      dbtRowKey = queryRegistration >>> (E.^. ExamRegistrationId)
-      dbtProj   = dbtProjId
-      dbtColonnade = mconcat
-          [ sortable (Just "course")      (i18nCell MsgTableCourse)               $ fmap addIndicatorCell courseCell <$> view (resultExmCourse . _entityVal)
-          , sortable (Just "exam")        (i18nCell MsgCourseExam)                $ \row -> examCell (row ^. resultExmCourse . _entityVal) (row ^. resultExam . _entityVal)
-          , sortable (Just "registration")(i18nCell MsgCourseExamRegistrationTime)$ dateCell . view (resultRegistration . _entityVal . _examRegistrationTime)
-          , sortable (Just "occurrence")  (i18nCell MsgTableExamOccurrence)       $ examOccurrenceCell              . view  resultOccurrence
-          , sortable (Just "testee")      (i18nCell MsgExamParticipant)           $ cellHasUserLink ForProfileDataR . view  resultTestee
-          , sortable (Just "examiner")    (i18nCell MsgExamCorrectors)            $ cellHasUser                     . view  resultExaminer
-          ]
-      validator = def & defaultSorting [SortAscBy "course", SortAscBy "exam", SortAscBy "testee"] -- [SortDescBy "registration"]
-      dbtSorting  = Map.fromList
-          [ ( "course"      , SortColumn $ queryExmCourse     >>> (E.^. CourseName))
-          , ( "exam"        , SortColumn $ queryExam          >>> (E.^. ExamName))
-          , ( "registration", SortColumn $ queryRegistration  >>> (E.^. ExamRegistrationTime))
-          , ( "occurrence"  , SortColumn $ queryOccurrence    >>> (E.^. ExamOccurrenceName))
-          , ( "testee"      , SortColumn $ queryTestee        >>> (E.^. UserDisplayName))
-          , ( "examiner"    , SortColumn $ queryExaminer      >>> (E.^. UserDisplayName))
-          ]
-      dbtFilter   = mempty
-      dbtFilterUI = mempty
-      dbtParams = def
-      dbtCsvEncode = noCsvEncode
-      dbtCsvDecode = Nothing
-      dbtExtraReps = []
-  in \ssh nd -> do
-    exOccs <- getDayExamOccurrences False ssh Nothing (nd,nd)
-    let dbtSQLQuery = dbtSQLQuery' $ Map.keys exOccs
-    (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
-

backend/src/Handler/Tutorial/Users.hs

@@ -1,375 +0,0 @@
--- SPDX-FileCopyrightText: 2022-2025 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# LANGUAGE TypeApplications, BlockArguments #-}
-
-
-module Handler.Tutorial.Users
-  ( getTUsersR, postTUsersR
-  , getTExamR, postTExamR
-  ) where
-
-import Import
-import Control.Monad.Zip (munzip)
-
-import Utils.Form
-import Utils.Print
-import Handler.Utils
-import Handler.Utils.Course
-import Handler.Utils.Course.Cache
-import Handler.Utils.Tutorial
-import Handler.Exam.Form (ExamOccurrenceForm(..), examOccurrenceMultiForm, upsertExamOccurrences, copyExamOccurrences)
-import Database.Persist.Sql (deleteWhereCount)
-
-import qualified Data.CaseInsensitive as CI
-
--- import qualified Data.Text as Text
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import qualified Data.ByteString.Lazy as LBS
--- import qualified Data.Time.Zones as TZ
-
-import           Database.Esqueleto.Experimental ((:&)(..))
-import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
-import qualified Database.Esqueleto.Utils        as E
-
-import Handler.Course.Users
-
-
-data TutorialUserAction
-  = TutorialUserAssignExam
-  | TutorialUserPrintQualification
-  | TutorialUserRenewQualification
-  | TutorialUserGrantQualification
-  | TutorialUserSendMail
-  | TutorialUserDeregister
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-
-instance Universe TutorialUserAction
-instance Finite TutorialUserAction
-nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
-embedRenderMessage ''UniWorX ''TutorialUserAction id
-
-data TutorialUserActionData
-  = TutorialUserPrintQualificationData
-  | TutorialUserRenewQualificationData
-    { tuQualification :: QualificationId }
-  | TutorialUserGrantQualificationData
-    { tuQualification :: QualificationId
-    , tuValidUntil    :: Maybe Day
-    }
-  | TutorialUserSendMailData
-  | TutorialUserDeregisterData
-  | TutorialUserAssignExamData
-    { tuOccurrenceId  :: ExamOccurrenceId
-    , tuExaminerAgain :: Bool
-    , tuReassign      :: Bool
-    }
-  deriving (Eq, Ord, Read, Show, Generic)
-
--- non-table form for general tutorial actions
-data GenTutAction
-  = GenTutActShowExam
-  | GenTutActOccCopyWeek
-  | GenTutActOccCopyLast
-  | GenTutActOccEdit
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-  deriving anyclass (Universe, Finite)
-
-nullaryPathPiece ''GenTutAction $ camelToPathPiece' 1
-embedRenderMessage ''UniWorX ''GenTutAction id
-
-data GenTutActionData = GenTutActionData { gtaAct :: GenTutAction, gtaExam :: ExamId }
-  deriving (Eq, Ord, Show, Generic)
-
--- mkGenTutForm :: [Filter Exam] -> Form GenTutActionData
--- mkGenTutForm fltr = renderAForm FormStandard maa
---   where
---     maa = multiActionA acts (fslI MsgCourseExam) Nothing
-
---     acts :: Map GenTutAction (AForm Handler GenTutActionData)
---     acts = Map.fromList
---             [ (GenTutActOccCopy, GenTutActOccCopyData <$> areq (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing)
---             , (GenTutActOccEdit, GenTutActOccEditData <$> aopt (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing)
---             ]
-mkGenTutForm :: [Filter Exam] -> Form GenTutActionData
-mkGenTutForm fltr html = do
-  (actRes, actView) <- mreq (selectFieldList ((\a->(a,a)) <$> universeF))              (fslI MsgCourseExam) Nothing
-  (exmRes, exmView) <- mreq (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing
-  let res :: FormResult GenTutAction -> FormResult ExamId -> FormResult GenTutActionData
-      res (FormSuccess gta) (FormSuccess eid) = FormSuccess $ GenTutActionData{gtaAct=gta, gtaExam=eid}
-      res (FormFailure e1) (FormFailure e2) = FormFailure $ e1 <> e2
-      res (FormFailure e) _ = FormFailure e
-      res _ (FormFailure e) = FormFailure e
-      res _ _ = FormMissing
-      viw = [whamlet|
-              <p>
-                #{html}^{fvInput actView} _{MsgFor} ^{fvInput exmView}
-            |]
-  return (res actRes exmRes, viw)
-
-
-getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent
-getTUsersR = postTUsersR
-postTUsersR tid ssh csh tutn = do
-  let heading = prependCourseTitle tid ssh csh $ CI.original tutn
-      croute  = CTutorialR tid ssh csh tutn TUsersR
-  now <- liftIO getCurrentTime
-  let nowaday = utctDay now
-  isAdmin <- hasReadAccessTo AdminR
-  (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications, dbegin, hasExams, exmFltr, exOccs) <- runDB do
-    trm <- get404 tid
-    -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-    -- tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
-    (cid, tutEnt@(Entity tutid _)) <- fetchCourseIdTutorial tid ssh csh tutn
-    qualifications <- getCourseQualifications cid
-    let dayExpiry = case nubOrd (mapMaybe (view _qualificationValidDuration) qualifications) of
-                      [oneDuration] -> Just $ Just $ computeNewValidDate oneDuration nowaday  -- suggest end day only if it is unique for all course qualifications
-                      _             -> Nothing                                                -- using the minimum here causes confusion, better leave blank!
-        colChoices  = mconcat $
-          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
-          , colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
-          , colUserEmail
-          , colUserMatriclenr isAdmin
-          ] <>
-          [ colUserQualificationBlocked isAdmin nowaday q | q <- qualifications] <>
-          [ colUserExamOccurrencesCheck tid ssh csh
-          , colUserExams tid ssh csh
-          ]
-        psValidator = def
-          & defaultSortingByName
-          & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
-          & restrictFilter  (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
-        isInTut q = E.exists do
-          tutorialParticipant <- E.from $ E.table @TutorialParticipant
-          E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
-               E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
-        csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
-        qualOptions = qualificationsOptionList qualifications
-        lessons  = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped'
-        timespan = lessonTimesSpan lessons
-        (dbegin, dend) = munzip timespan
-        tbegin = toMidnight . succ <$> dbegin
-        tend   = toMidnight        <$> dend
-        exmFltr = ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing]) ++ [ExamCourse ==. cid, ExamStart <=. tend]
-    -- $logInfoS "ExamOccurrenceForm" [st|Exams from #{tshow tbegin} until #{tshow tend}.|]
-    exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid -- :: ExamOccurrenceMap
-    hasExams <- if null exOccs then exists exmFltr else pure True
-    let
-      acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
-      acts = Map.fromList $
-        bcons (not $ null exOccs)
-            ( TutorialUserAssignExam
-            , TutorialUserAssignExamData
-                <$> apopt (selectField $ pure $ mkExamOccurrenceOptions exOccs) (fslI MsgCourseUserExamOccurrences) Nothing
-                <*> apopt checkBoxField (fslI MsgCourseUserExamOccurrenceAgainExaminer) (Just False)
-                <*> apopt checkBoxField (fslI MsgCourseUserExamOccurrenceOverride)      (Just False)
-            ) $
-        (if null qualifications then mempty else
-          [ ( TutorialUserRenewQualification
-            , TutorialUserRenewQualificationData
-              <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
-            )
-          , ( TutorialUserGrantQualification
-            , TutorialUserGrantQualificationData
-              <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
-              <*> aopt dayField (fslI MsgLmsQualificationValidUntil & setTooltip MsgTutorialUserGrantQualificationDateTooltip) dayExpiry
-            )
-          ]
-        ) ++
-        [ ( TutorialUserSendMail          , pure TutorialUserSendMailData           )
-        , ( TutorialUserDeregister        , pure TutorialUserDeregisterData         )
-        , ( TutorialUserPrintQualification, pure TutorialUserPrintQualificationData )
-        ]
-    table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices)
-    return (tutEnt, table, qualifications, dbegin, hasExams, exmFltr, exOccs)
-
-  let courseQids = entities2map qualifications
-  tcontent <- formResultMaybe participantRes $ \case
-    (TutorialUserPrintQualificationData, selectedUsers) -> do
-        rcvr <- requireAuth
-        encRcvr <- encrypt $ entityKey rcvr
-        letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
-        let mbAletter = anyone letters
-        case mbAletter of
-          Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- cannot really happen
-          Just aletter -> do
-            apcIdent <- letterApcIdent aletter encRcvr now
-            let fName = letterFileName aletter
-            renderLetters rcvr letters apcIdent >>= \case
-              Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
-              Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now)
-                -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
-                -- let typePDF :: ContentType
-                --     typePDF = "application/pdf"
-                -- sendResponse (typePDF, toContent pdf)
-    (TutorialUserGrantQualificationData{..}, selectedUsers)
-      | Just grantQual  <- Map.lookup tuQualification courseQids ->
-        case tuValidUntil <|> (flip computeNewValidDate nowaday <$> qualificationValidDuration grantQual) of
-          Nothing -> do -- TODO: change QualificationUser to have an optionnal validUntil for idefinitely valid qualifications
-            addMessageI Error $ MsgTutorialUserGrantQualificationDateError $ qualificationShorthand grantQual
-            return Nothing
-          (Just expiryDay) -> do
-            let qsh     = qualificationShorthand grantQual
-                reason  = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
-                selUsrs = Set.toList selectedUsers
-            expiryDayText <- formatTime SelFormatDate expiryDay
-            nterm <- runDB $ do
-              forM_ selUsrs $ upsertQualificationUser tuQualification now expiryDay Nothing reason
-              terminateLms (LmsOrphanReasonManualGrant [st|bis #{expiryDayText}, #{reason}|]) tuQualification selUsrs
-            addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification qsh expiryDayText $ Set.size selectedUsers
-            when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm
-            reloadKeepGetParams croute
-    (TutorialUserRenewQualificationData{..}, selectedUsers)
-      | Just grantQual  <- Map.lookup tuQualification courseQids -> do
-        let qsh     = qualificationShorthand grantQual
-            selUsrs = Set.toList selectedUsers
-        mr <- getMessageRender
-        (noks,nterm) <- runDB $ (,)
-          <$> renewValidQualificationUsers tuQualification Nothing Nothing selUsrs
-          <*> terminateLms (LmsOrphanReasonManualGrant $ mr heading) tuQualification selUsrs
-        addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification qsh noks
-        when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm
-        reloadKeepGetParams croute
-    (TutorialUserSendMailData, selectedUsers) -> do
-        cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
-        redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
-    (TutorialUserDeregisterData, selectedUsers) -> do
-        nrDel <- runDB $ deleteWhereCount
-          [ TutorialParticipantTutorial ==. tutid
-          , TutorialParticipantUser <-. Set.toList selectedUsers
-          ]
-        addMessageI Success $ MsgTutorialUsersDeregistered nrDel
-        reloadKeepGetParams croute
-    (TutorialUserAssignExamData{..}, setSelectedUsers)
-      | (Just (ExamOccurrence{..}, _, (eid,_))) <- Map.lookup tuOccurrenceId exOccs -> do
-        assignRes <- runDB $ do
-          (Set.toList &&& Set.size -> (selectedUsers, nr_usrs)) <- if -- remove duplicate examiners, if desired
-            | isJust examOccurrenceExaminer && not tuExaminerAgain -> do
-              conflictingUsers <- E.select $ do
-                reg :& occ <- E.from $  E.table @ExamRegistration
-                          `E.innerJoin` E.table @ExamOccurrence
-                          `E.on` (\(reg :& occ) -> occ E.^. ExamOccurrenceId E.=?. reg E.^. ExamRegistrationOccurrence)
-                E.where_ $ occ E.^. ExamOccurrenceExaminer E.==. E.val examOccurrenceExaminer
-                  E.&&.    occ E.^. ExamOccurrenceExam     E.!=. E.val examOccurrenceExam
-                  E.&&.   (reg E.^. ExamRegistrationUser `E.in_` E.vals setSelectedUsers)
-                E.orderBy [E.asc $ reg E.^. ExamRegistrationUser]
-                E.distinct $ pure $ reg E.^. ExamRegistrationUser
-              return $ setSelectedUsers `Set.difference` Set.fromAscList (E.unValue <$> conflictingUsers)
-            | otherwise -> return setSelectedUsers
-          runExceptT $ do
-            whenIsJust examOccurrenceCapacity $ \(fromIntegral -> totalCap) -> do
-              usedCap <- lift $ count [ExamRegistrationOccurrence ==. Just tuOccurrenceId, ExamRegistrationUser /<-. selectedUsers]
-              let remCap = totalCap - usedCap
-              when (nr_usrs > remCap) $ throwE $ MsgExamRoomCapacityInsufficient remCap
-            let regTemplate uid = ExamRegistration eid uid (Just tuOccurrenceId) now
-            lift $ if tuReassign
-              then putMany [regTemplate uid | uid <- selectedUsers] >> pure nr_usrs
-              else forM selectedUsers (insertUnique . regTemplate) <&> (length . catMaybes)
-        case assignRes of
-          Left errm   -> do
-            addMessageI Error errm
-            return Nothing
-          Right nrOk  -> do
-            let total = Set.size setSelectedUsers
-                allok = bool Warning Success $ nrOk == total
-            addMessageI allok $ MsgTutorialUserExamAssignedFor nrOk total $ ciOriginal examOccurrenceName
-            reloadKeepGetParams croute
-    _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
-
-  case tcontent of
-    Just act -> act -- execute action and return produced content (i.e. pdf)
-    Nothing -> do   -- no table action content to return, continue normally
-      let mkExamCreateBtn = linkButton mempty (msg2widget MsgMenuExamNew)  [BCIsButton, BCPrimary] $ SomeRoute $ CourseR tid ssh csh  CExamNewR
-      ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm ("FIDGeneralTutorialAction"::Text) $ mkGenTutForm exmFltr
-      let gtaAnchor  = "general-tutorial-action-form" :: Text
-          gtaRoute   = croute :#: gtaAnchor
-          gtaForm    = wrapForm' BtnPerform gtaWgt FormSettings
-                            { formMethod = POST
-                            , formAction = Just . SomeRoute $ gtaRoute
-                            , formEncoding = gtaEnctype
-                            , formAttrs = []
-                            , formSubmit = FormSubmit
-                            , formAnchor = Just gtaAnchor
-                            }
-          copyAction eId step = case dbegin of
-            Nothing  -> addMessageI Error MsgExamOccurrenceCopyNoStartDate
-            Just dto ->
-              let cfailure   = addMessageI Error    MsgExamOccurrenceCopyFail
-                  csuccess n = addMessageI Success (MsgExamOccurrencesCopied n) >> reloadKeepGetParams croute
-                  copyFrom dfrom = copyExamOccurrences eId dfrom dto <&> (toMaybe =<< (> 0))
-                  step_dto = addDays (negate step) dto
-              in  maybeM cfailure csuccess $
-                    runDB $ firstJustM $ map copyFrom $ take 69 $ drop 1 [dto, step_dto..] -- search for up to 2 months / 1 year backwards
-      formResult gtaRes $ \GenTutActionData{..} -> case gtaAct of
-        GenTutActOccCopyWeek -> copyAction gtaExam 7
-        GenTutActOccCopyLast -> copyAction gtaExam 1
-        GenTutActOccEdit -> do
-          Exam{examName=ename} <- runDBRead $ get404 gtaExam
-          redirect $ CTutorialR tid ssh csh tutn $ TExamR ename
-        GenTutActShowExam -> do
-          Exam{examName=ename} <- runDBRead $ get404 gtaExam
-          redirect (CExamR tid ssh csh ename EUsersR, [("exam-users-tutorial", toPathPiece tutn)])
-
-      tutors <- runDBRead $ E.select do
-                  (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
-                    `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
-                  E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
-                  return user
-      --   $(i18nWidgetFile "exam-missing")
-      html <- siteLayoutMsg heading do
-        setTitleI heading
-        $(widgetFile "tutorial-participants")
-      return $ toTypedContent html
-
-
-getTExamR, postTExamR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> ExamName -> Handler Html
-getTExamR = postTExamR
-postTExamR tid ssh csh tutn exmName = do
-  let baseroute  = CTutorialR tid ssh csh tutn
-  (Entity{entityKey=eId,entityVal=exm},exOccs) <- runDB do
-    trm <- get404 tid
-    (cid, tutEnt) <- fetchCourseIdTutorial tid ssh csh tutn
-    exm <- getBy404 $ UniqueExam cid exmName
-    let lessons  = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped'
-        timespan = lessonTimesSpan lessons
-        -- (fmap (toMidnight . succ) -> tbegin, fmap toMidnight -> tend) = munzip timespan
-    -- exms <- selectList ([ExamCourse ==. cid, ExamStart <=. tend] ++ ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing])) [Asc ExamName]
-    exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid
-    return (exm,exOccs)
-  cueId :: CryptoUUIDExam <- encrypt eId
-  let eid2eos = convertExamOccurrenceMap exOccs
-      (cuEoIds, eos) = munzip $ Map.lookup eId eid2eos
-      exOcForm = (,,)
-        <$> areq             hiddenField  "" (Just cueId)
-        <*> areq (mkSetField hiddenField) "" cuEoIds
-        <*> examOccurrenceMultiForm eos
-  ((eofRes, eofWgt), eofEnctype) <- runFormPost $ identifyForm FIDTutorialExamOccurrences $ renderAForm FormStandard exOcForm
-  let eofForm = wrapForm eofWgt def{formEncoding = eofEnctype}
-  formResult eofRes $ \(edCEId, edCEOIds, edOccs) -> do
-    let ceoidsDelete = edCEOIds `Set.difference` setMapMaybe eofId edOccs
-    $logInfoS "ExamOccurrenceEdit" [st|Exam-Edit: #{length edCEOIds} old occurrences, #{length ceoidsDelete} to delete, #{length $ Set.filter (isNothing . eofId) edOccs} to insert, #{length $ Set.filter (isJust . eofId) edOccs} to edit|]
-    reId <- decrypt edCEId
-    eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete
-    when (reId == eId) $ do
-      (fromIntegral -> nrDel, nrUps) <- runDB $ (,)
-        <$> deleteWhereCount [ExamOccurrenceExam ==. reId, ExamOccurrenceId <-. eoIdsDelete]
-        <*> upsertExamOccurrences eId (Set.toList edOccs)
-      let nr = nrUps + nrDel
-          mstat = if nr > 0 then Success else Warning
-      addMessageI mstat $ MsgExamOccurrencesEdited nrUps nrDel
-      reload $ baseroute $ TExamR exmName
-
-  let csh_tutn = csh <> "-" <> tutn -- hack to reuse prependCourseTitle
-      heading = prependCourseTitle tid ssh csh_tutn $ MsgMenuTutorialExam exmName
-  siteLayoutMsg heading do
-    -- setTitle $ citext2Html exmName
-    setTitleI heading
-    [whamlet|
-      <section>
-        <h2>#{CI.original exmName}
-        <p>#{examDescription exm}
-      <section>
-        ^{eofForm}
-    |]

backend/src/Handler/Utils.hs

@@ -1,247 +0,0 @@
--- SPDX-FileCopyrightText: 2023-2025 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Handler.Utils
-  ( module Handler.Utils
-  ) where
-
-import Import hiding (link)
-
-import Data.Map ((!))
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
-import Handler.Utils.DateTime as Handler.Utils
-import Handler.Utils.Form as Handler.Utils
-import Handler.Utils.Table as Handler.Utils
-
-import Handler.Utils.Zip        as Handler.Utils
-import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
--- import Handler.Utils.Submission as Handler.Utils
-import Handler.Utils.Sheet      as Handler.Utils
-import Handler.Utils.Mail       as Handler.Utils
-import Handler.Utils.ContentDisposition as Handler.Utils
-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
-import Handler.Utils.Files      as Handler.Utils
-import Handler.Utils.Download   as Handler.Utils
-import Handler.Utils.AuthorshipStatement as Handler.Utils
---import Handler.Utils.Company    as Handler.Utils
-import Handler.Utils.Qualification as Handler.Utils
-
-import Handler.Utils.Term as Handler.Utils
-
--- import Handler.Utils.Concurrent as Handler.Utils -- only imported when needed
-
-import Control.Monad.Logger
-
-
--- | default check if the user an active admin
-checkAdmin :: (MonadHandler m, MonadAP (HandlerFor (HandlerSite m) )) => m Bool
-checkAdmin = liftHandler $ hasReadAccessTo AdminR
-
--- | Prefix a message with a short course id,
---   eg. for window title bars, etc.
---   This function should help to make this consistent everywhere
-prependCourseTitle :: (RenderMessage master msg) =>
-  TermId -> SchoolId -> CourseShorthand -> msg -> SomeMessages master
-prependCourseTitle tid ssh csh msg = JoinMsgs
-  [ SomeMessage $ toPathPiece tid
-  , SomeMessage dashText
-  , SomeMessage $ toPathPiece ssh
-  , SomeMessage dashText
-  , SomeMessage csh
-  , SomeMessage colonText
-  , SomeMessage msg
-  ]
- where
-    dashText :: Text
-    dashText = "-"
-
-    colonText :: Text
-    colonText = ": "
-
-warnTermDays :: (RenderMessage UniWorX msg) => TermId -> Map UTCTime msg -> DB ()
-warnTermDays tid timeNames = do
-  Term{..} <- get404 tid
-  MsgRenderer mr <- getMsgRenderer
-  let alldays       = Map.keysSet timeNames
-      warnholidays  = let hdays = Set.fromList termHolidays in
-                      Set.filter (\(utctDay -> d) -> Set.member d hdays)                         alldays
-      outoftermdays = Set.filter (\(utctDay -> d) -> d < termStart        || d > termEnd       ) alldays
-      outoflecture  = Set.filter (\(utctDay -> d) -> d < termLectureStart || d > termLectureEnd) alldays
-                        `Set.difference` outoftermdays -- out of term implies out of lecture-time
-      warnI msg d   = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid (mr (timeNames ! d)) dt
-  forM_ warnholidays  $ warnI MsgDayIsAHoliday
-  forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
-  forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
-
-
--- | return a value only if the current user ist authorized for a given route
-guardAuthorizedFor :: ( MonadThrow m
-                      , MonadTrans t, MonadPlus (t (ReaderT SqlBackend m))
-                      , MonadAP (ReaderT SqlBackend m)
-                      )
-                   => Route UniWorX -> a -> t (ReaderT SqlBackend m) a
-guardAuthorizedFor link = guardMOn . lift $ hasReadAccessTo link
-
-
-runAppLoggingT :: UniWorX -> LoggingT m a -> m a
-runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
-  where
-    logFunc loc src lvl str = do
-      f <- messageLoggerSource app <$> readTVarIO loggerTVar
-      f loc src lvl str
-
-studyFeaturesWidget :: StudyFeaturesId -> Widget
-studyFeaturesWidget featId = do
-  (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandler . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
-  [whamlet|
-    $newline never
-    _{StudyDegreeTerm degree terms}, _{MsgTableStudyFeatureAge} #{studyFeaturesSemester}
-  |]
-
-
-getShowSex :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
-getShowSex = maybe False (userShowSex . entityVal) <$> maybeAuth
-
-
--- | Conditional redirect that hides the URL if the user is not authorized for the route
-redirectAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
-redirectAccess url = liftHandler $ do
-  -- must hide URL if not authorized
-  access <- isAuthorized url False
-  case access of
-    Authorized -> redirect url
-    _          -> permissionDeniedI MsgUnauthorizedRedirect
-
-redirectAccessWith :: (MonadHandler m, HandlerSite m ~ UniWorX) => Status -> Route (HandlerSite m) -> m a
-redirectAccessWith status url = liftHandler $ do
-  -- must hide URL if not authorized
-  access <- isAuthorized url False
-  case access of
-    Authorized -> redirectWith status url
-    _          -> permissionDeniedI MsgUnauthorizedRedirect
-
-redirectAlternatives :: (MonadHandler m, HandlerSite m ~ UniWorX) => NonEmpty (Route (HandlerSite m)) -> m a
-redirectAlternatives = go
-  where
-    go (nunsnoc -> ([], r)) = redirectAccess r
-    go (nunsnoc -> (r' : rs, r)) = liftHandler $ do
-      access <- isAuthorized r' False
-      case access of
-        Authorized -> redirect r'
-        _          -> redirectAlternatives (nsnoc rs r)
-
-    nunsnoc (x :| xs) = case nonEmpty xs of
-      Nothing  -> ([], x)
-      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` to current route, but also preserving all GET parameters, using the current route, if known
-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)
-
--- | like `reloadKeepGetParams`, but always leading to the specific route instead of the current route
-redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
-redirectKeepGetParams route = liftHandler $ do
-  getps <- reqGetParams <$> getRequest
-  redirect (route, getps)
-
-previousSuperior :: (IsDBTable m a) => Maybe UserId -> DBCell m a
-previousSuperior Nothing    = mempty
-previousSuperior (Just uid) = spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
-
-adminProblemCell :: (IsDBTable m a) => AdminProblem -> DBCell m a
--- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
--- WARNING: this function should correspond with adminProblem2Text
-adminProblemCell AdminProblemNewCompany{}
-  = i18nCell MsgAdminProblemNewCompany
-adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
-  = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
-adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
-  = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
-adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld}
-  = i18nCell MsgAdminProblemCompanySuperiorChange <> previousSuperior adminProblemUserOld
-adminProblemCell AdminProblemCompanySuperiorNotFound{..}
-  = i18nCell (MsgAdminProblemCompanySuperiorNotFound (fromMaybe "???" adminProblemEmail)) <> previousSuperior adminProblemUserOld
-adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
-  = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
-adminProblemCell AdminProblemUnknown{adminProblemText}
-  = textCell $ "Problem: " <> adminProblemText
-
-company2msg :: CompanyId -> SomeMessage UniWorX
-company2msg = text2message . ciOriginal . unCompanyKey
-
--- used to enable filtering, must correspond to function adminProblemCell shown above
-adminProblem2Text :: AdminProblem -> DB Text
-adminProblem2Text adprob = do
-  MsgRenderer mr <- getMsgRenderer
-  case adprob of
-    AdminProblemNewCompany{}
-      -> return $ mr MsgAdminProblemNewCompany
-    AdminProblemSupervisorNewCompany{adminProblemSupervisorReroute, adminProblemCompanyNew}
-      -> return $ mr $ SomeMsgs [SomeMessage $ MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute, company2msg adminProblemCompanyNew]
-    AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
-      -> return $ mr (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
-    AdminProblemCompanySuperiorChange{adminProblemUserOld=mbuid}
-      -> maybeT (return $ mr MsgAdminProblemCompanySuperiorChange) $ do
-          uid <- MaybeT $ pure mbuid
-          User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid
-          pure $ mr $ SomeMsgs [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
-    -- AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
-    --   -> return $ mr MsgAdminProblemCompanySuperiorChange
-    -- AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
-    --   -> get uid >>= \case
-    --       Nothing ->
-    --         return $ mr MsgAdminProblemCompanySuperiorChange
-    --       Just User{userDisplayName = udn, userSurname = usn} ->
-    --         return $ mr $ SomeMsgs [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
-    AdminProblemCompanySuperiorNotFound{adminProblemUserOld=mbuid, adminProblemEmail=eml}
-      ->  let basemsg = MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml
-          in  maybeT (return $ mr basemsg) $ do
-            uid <- MaybeT $ pure mbuid
-            User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid
-            pure $ mr $ SomeMsgs [SomeMessage basemsg, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
-    AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
-      -> return $ mr $ SomeMsgs [SomeMessage MsgAdminProblemNewlyUnsupervised, company2msg adminProblemCompanyNew]
-    AdminProblemUnknown{adminProblemText}
-      -> return $ "Problem: " <> adminProblemText
-
--- | Show AdminProblem as message, used in message pop-up after manually switching companies for a user
-msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
-msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
-  SomeMsgs [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
-msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $
-  SomeMsgs [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp]
-msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $
-  SomeMsgs [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp]
-msgAdminProblem AdminProblemCompanySuperiorChange{adminProblemCompany=comp} = return $
-  SomeMsgs [SomeMessage   MsgAdminProblemCompanySuperiorChange, text2message ": ", company2msg comp]
-msgAdminProblem AdminProblemCompanySuperiorNotFound{adminProblemCompany=comp, adminProblemEmail=eml} = return $
-  SomeMsgs [SomeMessage $ MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml, text2message ": ", company2msg comp]
-msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
-  SomeMsgs [SomeMessage   MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
-msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
-  someMessages ["Problem: ", err]
-
-updateAutomatic :: Bool -> Widget
--- updateAutomatic = iconTooltip [whamlet|_{MsgNoAutomaticUpdateTip}|] (Just IconLocked)
-updateAutomatic True  = mempty
-updateAutomatic False = do
-  msg <- messageIconI Warning IconLocked MsgNoAutomaticUpdateTip
-  messageTooltip msg

backend/src/Handler/Utils/AvsUpdate.hs

@@ -1,130 +0,0 @@
--- SPDX-FileCopyrightText: 2024-2025 Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-{-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-orphans #-}
--- Module for Template Haskell functions to be executed at compile time
--- to allow safe static partial functions
-
-module Handler.Utils.AvsUpdate where
-
-
-import Import
-
-{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}
-
--- import Utils.Avs
-
-
--- FAILED ATTEMPTS AT COMPILE-TIME-CHECKS USING TEMPLATE HASKELL:
--- import Language.Haskell.TH.Lift
--- import Language.Haskell.TH.Syntax
---
--- deriving instance Lift (EntityField User typ) -- possible
---
--- Lift instances for lenses are not possible:
--- type Getting r s a = (a -> Const r a) -> s -> Const r s
--- deriving instance Lift (Getting        typ AvsPersonInfo typ)
--- deriving instance Lift (Getting (First typ) AvsPersonInfo typ)
--- deriving instance Lift (CheckUpdate User AvsPersonInfo)
--- instance Lift (CheckUpdate User i) where
---     -- liftTyped :: forall (m :: Type -> Type). Quote m => t -> Code m t
---     liftTyped (CheckUpdate    up l) = [||CheckUpdate up l||]
---     liftTyped (CheckUpdateOpt up l) = [||CheckUpdateOpt up l||]
---
--- instance Lift (CheckUpdate record iraw) where
---     -- liftTyped :: forall (m :: Type -> Type). Quote m => t -> Code m t
---     lift = $(makeLift ''CheckUpdate)
--- mkUsrPerUpd upd = getUserPersonUpd $$(liftTyped upd)
-
-
-{-
-    CheckUpdate is usually a statically known pair between a DB record and a lens.
-    However, lenses cannot be an instance of Lift for compile time checking (see above).
-    Hence we encode the statically known pairs through a type family.
--}
-
-
-class MkCheckUpdate a where
-  type MCU_Rec a :: Type
-  type MCU_Raw a :: Type
-  mkCheckUpdate :: a -> CheckUpdate (MCU_Rec a) (MCU_Raw a)
-
-data CU_AvsPersonInfo_User
-  = CU_API_UserFirstName
-  | CU_API_UserSurname
-  | CU_API_UserDisplayName
-  | CU_API_UserBirthday
-  | CU_API_UserMobile
-  | CU_API_UserMatrikelnummer
-  | CU_API_UserCompanyPersonalNumber
-  | CU_API_UserLdapPrimaryKey
-  -- CU_API_UserDisplayEmail        -- use _avsContactPrimaryEmailAddress instead
-  deriving (Show, Eq)
-
-instance MkCheckUpdate CU_AvsPersonInfo_User where
-  type MCU_Rec CU_AvsPersonInfo_User = User
-  type MCU_Raw CU_AvsPersonInfo_User = AvsPersonInfo
-  mkCheckUpdate CU_API_UserFirstName             = CheckUpdate     UserFirstName               _avsInfoFirstName
-  mkCheckUpdate CU_API_UserSurname               = CheckUpdate     UserSurname                 _avsInfoLastName
-  mkCheckUpdate CU_API_UserDisplayName           = CheckUpdate     UserDisplayName             _avsInfoDisplayName
-  mkCheckUpdate CU_API_UserBirthday              = CheckUpdateMay  UserBirthday                _avsInfoDateOfBirth
-  mkCheckUpdate CU_API_UserMobile                = CheckUpdateMay  UserMobile                  _avsInfoPersonMobilePhoneNo
-  mkCheckUpdate CU_API_UserMatrikelnummer        = CheckUpdateMay  UserMatrikelnummer        $ _avsInfoPersonNo . re _Just                                              -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
-  mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdateMay  UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just   -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
-  mkCheckUpdate CU_API_UserLdapPrimaryKey        = CheckUpdateMay  UserLdapPrimaryKey        $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
-  -- mkCheckUpdate CU_API_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _avsInfoPersonEMail  . _Just . from _CI                                  -- Maybe im AvsInfo, aber nicht im User, daher Opt
-
-data CU_AvsDataContact_User
-  = CU_ADC_UserPostAddress
-  | CU_ADC_UserDisplayEmail
-  deriving (Show, Eq)
-
-instance MkCheckUpdate CU_AvsDataContact_User where
-  type MCU_Rec CU_AvsDataContact_User = User
-  type MCU_Raw CU_AvsDataContact_User = AvsDataContact
-  mkCheckUpdate CU_ADC_UserPostAddress  = CheckUpdateMay UserPostAddress    _avsContactPrimaryPostAddress
-  mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI
-
-data CU_AvsFirmInfo_User
-  = CU_AFI_UserPostAddress
-  -- CU_AFI_UserEmail               -- PROBLEM: UserEmail must be unique!
-  -- CU_AFI_UserDisplayEmail        -- use _avsContactPrimaryEmailAddress instead
-  deriving (Show, Eq)
-
-instance MkCheckUpdate CU_AvsFirmInfo_User where
-  type MCU_Rec CU_AvsFirmInfo_User = User
-  type MCU_Raw CU_AvsFirmInfo_User = AvsFirmInfo
-  mkCheckUpdate CU_AFI_UserPostAddress           = CheckUpdateMay  UserPostAddress             _avsFirmPostAddress
-  -- mkCheckUpdate CU_AFI_UserEmail              = CheckUpdateOpt  UserEmail                 $ _avsFirmEMailSuperior . _Just . from _CI   -- in rare cases, firm superior email is used as fallback here; but UserEmail must be unique!
-  -- mkCheckUpdate CU_AFI_UserDisplayEmail       = CheckUpdateOpt  UserDisplayEmail          $ _avsFirmPrimaryEmail  . _Just . from _CI   -- Maybe im AvsInfo, aber nicht im User, daher Opt
-
-
--- NOTE: Ensure that the lenses between CU_UserAvs_User and CU_AvsPersonInfo_User/CU_AvsFirmInfo_User agree!
-data CU_UserAvs_User                -- only used in templates/profileData.hamlet for detection
-  = CU_UA_UserPinPassword
-  -- CU_UA_UserPostAddress          -- use _avsContactPrimaryPostAddress instead
-  | CU_UA_UserFirstName
-  | CU_UA_UserSurname
-  | CU_UA_UserDisplayName
-  | CU_UA_UserBirthday
-  | CU_UA_UserMobile
-  | CU_UA_UserMatrikelnummer
-  | CU_UA_UserCompanyPersonalNumber
-  | CU_UA_UserLdapPrimaryKey
-  -- CU_UA_UserDisplayEmail         -- use _avsContactPrimaryEmail instead
-  deriving (Show, Eq)
-
-instance MkCheckUpdate CU_UserAvs_User where
-  type MCU_Rec CU_UserAvs_User = User
-  type MCU_Raw CU_UserAvs_User = UserAvs
-  mkCheckUpdate CU_UA_UserPinPassword           = CheckUpdateOpt  UserPinPassword           $ _userAvsLastCardNo     . _Just . to avsFullCardNo2pin . re _Just
-  -- mkCheckUpdate CU_UA_UserPostAddress           = CheckUpdateOpt  UserPostAddress           $ _userAvsLastFirmInfo   . _Just . _avsFirmPostAddress
-  mkCheckUpdate CU_UA_UserFirstName             = CheckUpdateOpt  UserFirstName             $ _userAvsLastPersonInfo . _Just . _avsInfoFirstName
-  mkCheckUpdate CU_UA_UserSurname               = CheckUpdateOpt  UserSurname               $ _userAvsLastPersonInfo . _Just . _avsInfoLastName
-  mkCheckUpdate CU_UA_UserDisplayName           = CheckUpdateOpt  UserDisplayName           $ _userAvsLastPersonInfo . _Just . _avsInfoDisplayName
-  mkCheckUpdate CU_UA_UserBirthday              = CheckUpdateOpt  UserBirthday              $ _userAvsLastPersonInfo . _Just . _avsInfoDateOfBirth
-  mkCheckUpdate CU_UA_UserMobile                = CheckUpdateOpt  UserMobile                $ _userAvsLastPersonInfo . _Just . _avsInfoPersonMobilePhoneNo
-  mkCheckUpdate CU_UA_UserMatrikelnummer        = CheckUpdateOpt  UserMatrikelnummer        $ _userAvsLastPersonInfo . _Just . _avsInfoPersonNo . re _Just                                              -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just
-  mkCheckUpdate CU_UA_UserCompanyPersonalNumber = CheckUpdateOpt  UserCompanyPersonalNumber $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just   -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov
-  mkCheckUpdate CU_UA_UserLdapPrimaryKey        = CheckUpdateOpt  UserLdapPrimaryKey        $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
-  -- mkCheckUpdate CU_UA_UserDisplayEmail          = CheckUpdateOpt  UserDisplayEmail          $ _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail  . _Just . from _CI

backend/src/Handler/Utils/Company.hs

@@ -1,289 +0,0 @@
--- SPDX-FileCopyrightText: 2022-2025 Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# LANGUAGE BlockArguments #-}         -- do starts is own block
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Handler.Utils.Company where
-
-
-import Import
-
--- import Data.CaseInsensitive (CI)
--- import qualified Data.CaseInsensitive as CI
--- import qualified Data.Char as Char
--- import qualified Data.Text as Text
-import Database.Persist.Postgresql
-
-import           Database.Esqueleto.Experimental ((:&)(..))
-import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
-import qualified Database.Esqueleto.Utils        as E
-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
---      E.where_ $ othr E.^. UserCompanyPriority E.>.  userCompany E.^. UserCompanyPriority
---          E.&&.  othr E.^. UserCompanyUser     E.==. userCompany E.^. UserCompanyUser
---          E.&&.  othr E.^. UserCompanyCompany  E.!=. E.val cid                       -- redundant due to > above, but likely performance improving
---    )
-
-company2msg :: CompanyId -> SomeMessage UniWorX
-company2msg = text2message . ciOriginal . unCompanyKey
-
--- for convenience in debugging
-instance ToText (Maybe CompanyId) where
-  toText Nothing    = toText ("-None-"::Text)
-  toText (Just fsh) = toText $ unCompanyKey fsh
-
-wgtCompanies :: Bool -> UserId -> DB (Maybe Widget)
-wgtCompanies useShort = (wrapUL . fst <<$>>) . wgtCompanies' useShort
-  where
-    wrapUL wgt = [whamlet|<ul .list--iconless>^{wgt}|]
-
--- | Given a UserId, create widget showing top-companies (with internal link) and associated companies (unlinked)
---   NOTE: The widget must be wrapped with <ul>
-wgtCompanies' :: Bool -> UserId -> DB (Maybe (Widget, [(CompanyShorthand,CompanyName,Bool,Int)]))
-wgtCompanies' useShort uid = do
-    companies <- $(E.unValueN 4) <<$>> E.select do
-      (usrComp :& comp) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @Company
-        `E.on` (\(usrComp :& comp) -> usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId)
-      E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
-      E.orderBy [E.asc (comp E.^. CompanyName)]
-      return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor, usrComp E.^. UserCompanyPriority)
-    let (mPri, topCmp, otherCmp) = procCmp mPri companies
-        resWgt =
-          [whamlet|
-            $forall c <- topCmp
-              <li>
-                ^{c}
-            $forall c <- otherCmp
-              <li>
-                ^{c}
-          |]
-    return $ toMaybe (notNull companies) (resWgt, companies)
-  where
-    procCmp _ [] = (0, [], [])
-    procCmp maxPri ((cmpSh, cmpName, cmpSpr, cmpPrio) : cs) =
-      let isTop  = cmpPrio >= maxPri
-          cmpWgt = companyWidget' useShort isTop (cmpSh, cmpName, cmpSpr)
-          (accPri,accTop,accRem) = procCmp maxPri cs
-      in  ( max cmpPrio accPri
-          , bool           accTop  (cmpWgt : accTop)    isTop -- lazy evaluation after repmin example, don't factor out the bool!
-          , bool (cmpWgt : accRem)           accRem     isTop
-          )
-
-type AnySuperReason = Either SupervisorReason (Maybe Text)
-
-
-addDefaultSupervisors' :: CompanyId -> NonEmpty UserId -> DB Int64
-addDefaultSupervisors' = addDefaultSupervisors $ Just $ tshow SupervisorReasonCompanyDefault
-
--- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
--- if no reason is given, SupervisorReasonCompanyDefault is used, except if reason == Just "NULL"
-addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
-addDefaultSupervisors reason cid employees = do
-  E.insertSelectWithConflictCount UniqueUserSupervisor
-    (do
-      (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
-      E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
-          E.&&.  spr E.^. UserCompanySupervisor
-      E.distinct $ return $ UserSupervisor
-        E.<#  (spr E.^. UserCompanyUser)
-        E.<&>  usr
-        E.<&> (spr E.^. UserCompanySupervisorReroute)
-        E.<&> E.justVal cid
-        E.<&> case reason of
-                Nothing     -> E.justVal $ tshow SupervisorReasonCompanyDefault
-                Just "NULL" -> E.nothing
-                other       -> E.val other
-    )
-    (\old new ->
-      [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-      , UserSupervisorCompany E.=. E.justVal cid
-      , UserSupervisorReason  E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
-      ]
-    )
-
-
--- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
--- TODO: check redundancies
-addDefaultSupervisorsFor ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64
-addDefaultSupervisorsFor reason mbSuperId mutualSupervision cids = do
-  E.insertSelectWithConflictCount UniqueUserSupervisor
-    (do
-      (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
-      E.where_ $ E.and $ guardMonoid (not mutualSupervision)
-                            [ E.not__ $ usr E.^. UserCompanySupervisor ]
-                        <>  maybeEmpty mbSuperId (\sprId -> [E.exists $ do
-                              superv <- E.from $ E.table @UserSupervisor
-                              E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
-                                  E.&&.  superv E.^. UserSupervisorUser       E.==. usr E.^. UserCompanyUser
-                            ])
-                        <>  [          spr E.^. UserCompanySupervisor
-                            , spr E.^. UserCompanyCompany `E.in_` E.vals cids
-                            , usr E.^. UserCompanyCompany `E.in_` E.vals cids
-                            ]
-      E.distinct $ return $ UserSupervisor
-        E.<#  (spr E.^. UserCompanyUser)
-        E.<&> (usr E.^. UserCompanyUser)
-        E.<&> (spr E.^. UserCompanySupervisorReroute)
-        E.<&> E.just (spr E.^. UserCompanyCompany)
-        E.<&> E.val reason
-    )
-    (\old new ->
-        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-        , UserSupervisorReason  E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
-        ] )
-
--- like `addDefaultSupervisors`, but selects all employees of given companies from database
--- TODO: check redundancies
-addDefaultSupervisorsAll ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
-addDefaultSupervisorsAll reason mutualSupervision cids = do
-  E.insertSelectWithConflictCount UniqueUserSupervisor
-    (do
-      (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
-      E.where_ $ E.and $ guardMonoid (not mutualSupervision)
-                            [ E.not__ $ usr E.^. UserCompanySupervisor ]
-                        <>  [          spr E.^. UserCompanySupervisor
-                            , spr E.^. UserCompanyCompany `E.in_` E.vals cids
-                            , usr E.^. UserCompanyCompany `E.in_` E.vals cids
-                            ]
-      E.distinct $ return $ UserSupervisor
-        E.<#  (spr E.^. UserCompanyUser)
-        E.<&> (usr E.^. UserCompanyUser)
-        E.<&> (spr E.^. UserCompanySupervisorReroute)
-        E.<&> E.just (spr E.^. UserCompanyCompany)
-        E.<&> E.val reason
-    )
-    (\old new ->
-        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-        , UserSupervisorReason  E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
-        ] )
-
--- | removes user supervisorship on switch. WARNING: problems are only returned, but not yet written to DB via reportProblem
-switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
-switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do
-    usrRec      <- get404 uid
-    newCompany  <- get404 newCompanyId
-    mbUsrComp   <- getUserPrimaryCompany uid
-    mbOldComp   <- (get . userCompanyCompany) `traverseJoin` mbUsrComp
-    mbUsrAvs    <- if usrPostEmailUpds then getBy (UniqueUserAvsUser uid) else return Nothing
-    let usrPostAddr :: Maybe StoredMarkup = userPostAddress usrRec
-        avsPostAddr :: Maybe StoredMarkup = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just
-        usrPostUp = toMaybe (usrPostEmailUpds && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr))
-                      (UserPostAddress =. Nothing)                                                   -- use company address indirectly instead
-        usrPrefPost = userPrefersPostal usrRec
-        usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
-                      (UserPrefersPostal  =. companyPrefersPostal newCompany)
-        usrPinPassUp = toMaybe (newCompany ^. _companyPinPassword . _not) (UserPinPassword =. Nothing)
-        -- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany
-        usrDisplayEmail :: UserEmail       = userDisplayEmail usrRec
-        avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI
-        usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email
-        usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrPinPassUp, usrDisplayEmailUp]
-        newUserComp       = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
-        superReasonComDef = tshow SupervisorReasonCompanyDefault
-
-    -- update uid usrUpdate
-    -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association
-    case mbUsrComp of
-      Nothing -> do -- create company user
-        void $ insertUnique newUserComp
-        newAPs <- addDefaultSupervisors' newCompanyId $ singleton uid
-        $logInfoS "Supervision" [st|switchAvsUserCompany for #{tshow uid} to #{unCompanyKey newCompanyId}. #{newAPs} default company supervisors upserted.|]
-        return (usrUpdate, mempty)
-      Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
-        | newCompanyId == oldCompanyId -> return mempty -- nothing to do
-        | otherwise -> do -- switch company
-            when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
-            let newPrio = succ oldPrio
-            void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = newPrio}
-              [UserCompanyPriority =. newPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
-            -- supervised by uid
-            supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
-              usrSup <- E.from $ E.table @UserSupervisor
-              E.where_ $ usrSup E.^. UserSupervisorSupervisor E.==. E.val uid
-                  E.&&.  usrSup E.^. UserSupervisorCompany    E.~=. E.val oldCompanyId
-                  E.&&.  usrSup E.^. UserSupervisorReason     E.~=. E.val superReasonComDef
-              let singleSup = E.notExists $ do
-                    othSup <- E.from $ E.table @UserSupervisor
-                    E.where_ $ usrSup E.^. UserSupervisorUser     E.==. othSup E.^. UserSupervisorUser
-                        E.&&.  othSup E.^. UserSupervisorCompany  E.~=. E.val oldCompanyId
-                        E.&&.  othSup E.^. UserSupervisorReason   E.~=. E.val superReasonComDef
-              return (usrSup, singleSup)
-            newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do
-              E.delete $ do
-                usrSup <- E.from $ E.table @UserSupervisor
-                E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees)
-              return $  [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute
-                        | (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True)  <- supervisees ]
-            -- supervisors of uid
-            let superDeftFltr     = (UserSupervisorUser ==. uid) : (UserSupervisorReason  ~=. superReasonComDef)  -- default or no reason
-                oldSubFltr        = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr                     -- old company or no company
-            oldAPs <- if keepOldCompanySupervs
-              then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
-              else deleteWhereCount oldSubFltr
-            nrDefSups <- addDefaultSupervisors' newCompanyId $ singleton uid -- CHECK HERE WITH LINES ABOVE
-            newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
-            let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
-                problems = bcons oldSuper             (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
-                         $ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
-                           newlyUnsupervised
-                delupd = bool "deleted" "updated" keepOldCompanySupervs :: Text
-            $logInfoS "Supervision" [st|switchAvsUserCompany for #{tshow uid} from #{unCompanyKey oldCompanyId} to #{unCompanyKey newCompanyId}. #{oldAPs} old APs #{delupd}. #{nrDefSups} default company supervisors upserted. #{newAPs} new company supervisors counted now.|]
-            return (usrUpdate ,problems)
-
-defaultSupervisorReasonFilter :: [Filter UserSupervisor]
-defaultSupervisorReasonFilter =
-        [UserSupervisorReason  ==. Nothing]
-    ||. [UserSupervisorReason  ==. Just (tshow SupervisorReasonCompanyDefault)]
-    ||. [UserSupervisorReason  ==. Just (tshow SupervisorReasonAvsSuperior   )]
---  ||. [UserSupervisorReason <-. Nothing : [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] -- Does <-. work with Nothing?
-
--- | remove supervisors for given users; maybe restricted to those linked to given companies or supervisors
-deleteDefaultSupervisorsForUsers :: [CompanyId] -> [UserId] -> NonEmpty UserId -> DB Int64
-deleteDefaultSupervisorsForUsers cids sprs usrs =
-    deleteWhereCount
-      $ bcons (notNull cids) (UserSupervisorCompany     <-. (cids <&> Just))
-      $ bcons (notNull sprs) (UserSupervisorSupervisor  <-.  sprs)
-      $ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
-
--- | retrieve maximum company user priority for a user
-
-getCompanyUserMaxPrio :: UserId -> DB Int
-getCompanyUserMaxPrio uid = do
-  mbMaxPrio <- E.selectOne $ do
-    usrCmp <- E.from $ E.table @UserCompany
-    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 $ 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_ $ uc E.^. UserCompanyUser E.==. uid
-  E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
-  return (uc E.^. UserCompanyCompany)

backend/src/Handler/Utils/Course/Cache.hs

@@ -1,188 +0,0 @@
--- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Handler.Utils.Course.Cache where
-
-import Import
-
-import Handler.Utils
--- import Handler.Utils.Occurrences
-import Handler.Exam.Form (ExamOccurrenceForm(..))
-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
--- import qualified Data.Aeson  as Aeson
-
-
--- import Database.Persist.Sql (updateWhereCount)
-import           Database.Esqueleto.Experimental ((:&)(..))
-import qualified Database.Esqueleto.Experimental as E
-import qualified Database.Esqueleto.Utils as E
--- import           Database.Esqueleto.PostgreSQL.JSON ((@>.))
--- import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.))
-
-
-
---   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..=
---     [ Aeson.object
---       [ "exception" Aeson..= ("occur"::Text)
---       , "day"       Aeson..= d
---   ] ] ]
-
-{- More efficient DB-only version, but ignores regular schedules
-getDayTutorials :: SchoolId -> Day -> DB [TutorialId]
-getDayTutorials ssh d = E.unValue <<$>> 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
-  )
--}
-
--- | Datatype to be used as key for memcaching DayTask related stuff; note that newtype-CacheKeys are optimized away, so multiple constructors are advisable
-data CourseCacheKeys
-  = CacheKeyTutorialOccurrences  SchoolId (Day,Day)                   -- ^ Map TutorialId (TutorialName, [LessonTime])
-  | CacheKeyExamOccurrences      SchoolId (Day,Day) (Maybe CourseId)  -- ^ Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence)
-  | CacheKeySuggsParticipantNote SchoolId TutorialId
-  | CacheKeySuggsAttendanceNote  SchoolId TutorialId
-  | CacheKeyTutorialCheckResults SchoolId Day
-  deriving (Eq, Ord, Read, Show, Generic)
-  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) (CacheKeyTutorialOccurrences ssh dlimit) $ do  -- same key is ok, distinguished by return type
---     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, 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 -- 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
---         = Nothing
-
--- | like the previous version above, but also returns the lessons occurring within the given time frame
---   Due to caching, we only use the more informative version, unless experiments with the full DB show otherwise
-getDayTutorials :: SchoolId -> (Day,Day) -> DB (Map TutorialId (TutorialName, [LessonTime]))
-getDayTutorials ssh dlimit@(dstart, dend )
-  | dstart > dend = return mempty
-  | 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)
-          `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 (TutorialName, [LessonTime])
-    checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ, tutorialName=tName}})
-      | let lessons = Set.filter lessonFltr $ occurringLessons trm occ
-      , notNull lessons
-        = Map.singleton tutId (tName , 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
-
---  -- retrieve all exam occurrences for a school for a term in a given time period; uses caching
--- getDayExamOccurrences :: SchoolId -> (Day,Day) -> DB (Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence))
--- getDayExamOccurrences ssh dlimit@(dstart, dend )
---   | dstart > dend = return mempty
---   | otherwise = memcachedByClass MemcachedKeyClassExamOccurrences (Just . Right $ 12 * diffDay) (CacheKeyExamOccurrences ssh dlimit) $ do
---     candidates <- E.select $ do
---       (trm :& crs :& exm :& occ) <- 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 @Exam            `E.on` (\(_ :& crs :& exm)        -> crs E.^. CourseId   E.==. exm E.^. ExamCourse)
---           `E.innerJoin` E.table @ExamOccurrence  `E.on` (\(_ :& _   :& exm :& occ) -> exm E.^. ExamId     E.==. occ E.^. ExamOccurrenceExam)
---       E.where_ $ E.val     ssh    E.==. crs E.^. CourseSchool
---         E.&&.    E.val     dstart E.<=. trm E.^. TermEnd
---         E.&&.    E.val     dend   E.>=. trm E.^. TermStart
---         E.&&. ( E.between (E.day      $ occ E.^. ExamOccurrenceStart) (E.val     dstart, E.val     dend)
---           E.||. E.between (E.dayMaybe $ occ E.^. ExamOccurrenceEnd)   (E.justVal dstart, E.justVal dend)
---           )
---       return (exm, occ)
---     return $ foldMap mkOccMap candidates
---   where
---     mkOccMap :: (Entity Exam, Entity ExamOccurrence) -> Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence)
---     mkOccMap (entityVal -> exm, Entity{..}) = Map.singleton entityKey (exm ^. _examCourse, exm ^. _examName, entityVal)
-
-type ExamOccurrenceMap = Map ExamOccurrenceId (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))
-type ExamToOccurrencesMap  = Map ExamId (Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)
-
--- | retrieve all exam occurrences for a school in a given time period, ignoring term times; uses caching
---   if a CourseId is specified, only exams from that course are returned
-getDayExamOccurrences :: Bool -> SchoolId -> Maybe CourseId -> (Day,Day) -> DB ExamOccurrenceMap
-getDayExamOccurrences onlyOpen ssh mbcid dlimit@(dstart, dend)
-  | dstart > dend = return mempty
-  | otherwise = memcachedByClass MemcachedKeyClassExamOccurrences (Just . Right $ 12 * diffDay) (CacheKeyExamOccurrences ssh dlimit mbcid) $ do
-    now <- liftIO getCurrentTime
-    candidates <- E.select $ do
-      (crs :& exm :& occ) <- E.from $ E.table @Course
-          `E.innerJoin` E.table @Exam            `E.on` (\(crs :& exm)        -> crs E.^. CourseId   E.==. exm E.^. ExamCourse)
-          `E.innerJoin` E.table @ExamOccurrence  `E.on` (\(_   :& exm :& occ) -> exm E.^. ExamId     E.==. occ E.^. ExamOccurrenceExam)
-      E.where_ $ E.and $ catMaybes
-        [ toMaybe onlyOpen $ E.justVal now E.>=. exm E.^. ExamRegisterFrom -- fail on null
-                      E.&&.  E.val     now E.<~. exm E.^. ExamRegisterTo   -- success on null
-        , mbcid <&> ((E.==. (crs E.^. CourseId)) . E.val)
-        , Just $ crs E.^. CourseSchool E.==. E.val ssh
-        , Just $ E.withinPeriod dlimit (occ E.^. ExamOccurrenceStart) (occ E.^. ExamOccurrenceEnd)
-        ]
-      -- E.orderBy [E.asc $ exm E.^. ExamName] -- we return a map, so the order does not matter
-      return (occ, exm E.^. ExamId, exm E.^. ExamName) -- No Binary instance for Entity Exam, so we only extract what is needed for now
-    foldMapM mkOccMap candidates
-  where
-    mkOccMap :: (Entity ExamOccurrence, E.Value ExamId, E.Value ExamName) -> DB ExamOccurrenceMap
-    mkOccMap (Entity{..}, E.Value eId, E.Value eName) = encrypt entityKey <&> (\ceoId -> Map.singleton entityKey (entityVal, ceoId, (eId, eName)))
-
-mkExamOccurrenceOptions :: ExamOccurrenceMap -> OptionList ExamOccurrenceId
-mkExamOccurrenceOptions = mkOptionListGrouped . map (over _2 $ sortBy (compare `on` optionDisplay)) . groupSort . map mkEOOption . Map.toList
-  where
-    mkEOOption :: (ExamOccurrenceId, (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))) -> (Text, [Option ExamOccurrenceId])
-    mkEOOption (eid, (ExamOccurrence{examOccurrenceName}, ceoId, (_,eName))) = (ciOriginal eName, [Option{..}])
-      where
-        optionDisplay       = ciOriginal examOccurrenceName
-        optionExternalValue = toPathPiece ceoId
-        optionInternalValue = eid
-
-convertExamOccurrenceMap :: ExamOccurrenceMap -> ExamToOccurrencesMap
-convertExamOccurrenceMap eom = Map.fromListWith (<>) $ map aux $ Map.toList eom
-  where
-    aux :: (ExamOccurrenceId, (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))) -> (ExamId, (Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm))
-    aux (_, (ExamOccurrence{..}, cueoId, (eid,_))) = (eid, (Set.singleton cueoId, Set.singleton ExamOccurrenceForm
-            { eofId          = Just cueoId
-            , eofName        = Just examOccurrenceName
-            , eofExaminer    = examOccurrenceExaminer
-            , eofRoom        = examOccurrenceRoom
-            , eofRoomHidden  = examOccurrenceRoomHidden
-            , eofCapacity    = examOccurrenceCapacity
-            , eofStart       = examOccurrenceStart
-            , eofEnd         = examOccurrenceEnd
-            , eofDescription = examOccurrenceDescription
-            }
-          ))

backend/src/Handler/Utils/Occurrences.hs

@@ -1,196 +0,0 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Handler.Utils.Occurrences
-  ( LessonTime(..)
-  , lessonTimeWidget, lessonTimesWidget
-  , lessonTimesSpan
-  , occurringLessons
-  , occurrencesWidget
-  , occurrencesCompute, occurrencesCompute'
-  , occurrencesBounds
-  , occurrencesAddBusinessDays
-  ) where
-
-import Import
-
-import qualified Data.Set as Set
-
-import Utils.Holidays (isWeekend)
-import Utils.Occurrences
-
-import Handler.Utils.DateTime
-import Handler.Utils.Widgets (roomReferenceWidget)
-
--- import Text.Read (read) -- for DEBUGGING only
-
-
-----------------
--- LessonTime --
-----------------
---
--- Model time intervals to compute lecture/tutorial lessons more intuitively
---
-
-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
-  where
-    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 -- 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
-                                    , lessonEnd   = LocalTime d scheduleEnd
-                                    , lessonRoom  = scheduleRoom
-                                    }
-        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
-                          , 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")
-
-lessonTimesSpan :: Set LessonTime -> Maybe (Day, Day)
-lessonTimesSpan ls = comb (Set.lookupMin lDays, Set.lookupMax lDays)
-  where
-    lDays = Set.foldr accDay mempty ls
-    accDay LessonTime{..} = Set.insert (localDay lessonStart) . Set.insert (localDay lessonEnd)
-    comb (Just x, Just y) = Just (x,y)
-    comb _ = Nothing
-
-
------------------
--- Occurrences --
------------------
-
-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
-          scheduleEnd' <- formatTime SelFormatTime scheduleEnd
-          $(widgetFile "widgets/occurrence/cell/weekly")
-      occurrencesExceptions' = flip map (Set.toList occurrencesExceptions) $ \case
-        ExceptOccur{..} -> do
-          exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
-          exceptEnd'   <- formatTime SelFormatTime     exceptEnd
-          $(widgetFile "widgets/occurrence/cell/except-occur")
-        ExceptNoOccur{..} -> do
-          exceptTime' <- formatTime SelFormatDateTime exceptTime
-          $(widgetFile "widgets/occurrence/cell/except-no-occur")
-  $(widgetFile "widgets/occurrence/cell")
-
--- | 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 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
-
-    getExcDays :: OccurrenceException -> (Set Day, Set Day) -> (Set Day, Set Day)
-    getExcDays ExceptNoOccur{exceptTime} (occ,exc) = (occ, Set.insert (localDay exceptTime) exc)
-    getExcDays ExceptOccur{exceptDay}    (occ,exc) = (Set.insert exceptDay occ, exc)
-
-    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
-    newSchedule = Set.map switchDayOfWeek occurrencesScheduled
-    dayDiff = diffDays dayNew dayOld
-
-    offDays = Set.fromList $ termHolidays <> weekends
-    weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d]
-
-    switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule
-    switchDayOfWeek os | 0 == dayDiff `mod` 7 = os
-    switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (fromIntegral dayDiff + fromEnum wday)}
-
-    newExceptions = snd $ Set.foldl' advanceExceptions (dayDiff,mempty) occurrencesExceptions
-
-    -- we assume that instance Ord OccurrenceException is ordered chronologically
-    advanceExceptions :: (Integer, Set OccurrenceException) -> OccurrenceException -> (Integer, Set OccurrenceException)
-    advanceExceptions (offset, acc) ex
-        | ed `Set.notMember` offDays   -- skip term-holidays and weekends, unless the original day was a holiday or weekend
-        , nd `Set.member`    offDays
-          = advanceExceptions (succ offset, acc) ex
-        | otherwise
-          = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc)
-      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"
-  }
-
--}

backend/src/Handler/Utils/Table.hs

@@ -1,38 +0,0 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Handler.Utils.Table
-  ( module Handler.Utils.Table
-  ) where
-
-import Import hiding (link)
-
-import Handler.Utils.Table.Pagination as Handler.Utils.Table
-import Handler.Utils.Table.Columns as Handler.Utils.Table
-import Handler.Utils.Table.Cells as Handler.Utils.Table
-
-
--- | Given a header message, a bool and widget; display widget and header only if the boolean is true
-maybeTable :: (RenderMessage UniWorX a)
-           => a -> (Bool, Widget) -> Widget
-maybeTable m = maybeTable' m Nothing Nothing
-
-maybeTable' :: (RenderMessage UniWorX a)
-           => a -> Maybe a -> Maybe Widget -> (Bool, Widget) -> Widget
-maybeTable' _   Nothing       _ (False, _ ) = mempty
-maybeTable' _   (Just nodata) _ (False, _ ) =
-  [whamlet|
-    <div .container>
-      _{nodata}
-  |]
-maybeTable' hdr _ mbRemark      (True ,tbl) =
-  [whamlet|
-    <div .container>
-      <h2> _{hdr}
-      <div .container>
-        ^{tbl}
-        $maybe remark <- mbRemark
-          <em>_{MsgProfileRemark}
-          \ ^{remark}
-  |]

backend/src/Handler/Utils/avs_callgraph.md

@@ -1,47 +0,0 @@
-# Demo
-## Mermaid Flowcharts
-
-```mermaid
-flowchart LR;
-  gau([guessAvsUser])
-  %% uau([XupsertAvsUser])
-  uaubi[upsertAvsUserById]
-  uaubis[upsertAvsUserByIds]
-  uaubc[upsertAvsUserByCard]
-  ldap[[ldapLookupAndUpsert]]
-  lau[lookupAvsUser]
-  laus[lookupAvsUsers - DEPRECATED?]
-  gla[guessLicenceAddress - DEPRECATED]
-  ur([?updateReceivers])
-  caubi[createAvsUserById]
-  ucomp[upsertAvsCompany]
-
-  aqc{{AvsQueryContact}}
-  aqp{{AvsQueryPerson}}
-  aqs{{AvsQueryStatus}}
-
-  
-  uaubc-->uaubi
-  uaubc-->aqp
-  
-  gau-->uaubi
-  gau-->uaubc
-  gau-->ldap
-  
-  %% uau-..->uaubi
-  %% uau-..->uaubc
-  
-  uaubi-->uaubis
-  uaubi-->caubi-->uaubis
-  uaubis-->aqc
-  caubi-->aqs
-  caubi-->aqc
-
-  caubi-->ucomp
-  uaubis-->ucomp
-
-  lau-->laus
-  laus-->aqs
-
-  ur-->uaubi
-```

backend/src/Jobs/Handler/SynchroniseAvs.hs

@@ -1,193 +0,0 @@
--- SPDX-FileCopyrightText: 2022-2023 Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Jobs.Handler.SynchroniseAvs
-  ( dispatchJobSynchroniseAvs
-  -- , dispatchJobSynchroniseAvsId
-  -- , dispatchJobSynchroniseAvsUser
-  , dispatchJobSynchroniseAvsQueue
-  , dispatchJobSynchroniseAvsLicences
-  , dispatchJobSynchroniseByAvsDataContact
-  ) where
-
-import Import
-
-import qualified Data.Text            as Text
-import qualified Data.Set             as Set
--- import qualified Data.Map             as Map
-import qualified Data.Conduit.List as C
-
-import           Database.Esqueleto.Experimental ((:&)(..))
-import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
--- import qualified Database.Esqueleto.Legacy as E hiding (upsert)
--- import qualified Database.Esqueleto.PostgreSQL as E
-import qualified Database.Esqueleto.Utils as E
-
-import Jobs.Queue
-
-import Handler.Utils.Avs
-import Handler.Utils.Qualification
-
--- pause is a date in the past; don't synch again if the last synch was after pause
-dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX
-dispatchJobSynchroniseAvs numIterations epoch iteration pause
-  = JobHandlerException . runDB $ do
-      now <- liftIO getCurrentTime
-      todos <- runConduit $ readUsers .| filterIteration now .| sinkList
-      putMany todos
-      $logInfoS "SynchronisAvs" [st|AVS synch summary for #{tshow numIterations}/#{tshow epoch}/#{tshow iteration}: #{length todos}|]
-      void $ queueJob JobSynchroniseAvsQueue
-  where
-    readUsers :: ConduitT () UserId _ ()
-    readUsers = selectKeys [] []
-
-    filterIteration :: UTCTime -> ConduitT UserId AvsSync _ ()
-    filterIteration now = C.mapMaybeM $ \userId -> runMaybeT $ do
-      let
-        userIteration, currentIteration :: Integer
-        userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
-        currentIteration = toInteger iteration `mod` toInteger numIterations
-      $logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: AVS sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
-      guard $ userIteration == currentIteration
-      return $ AvsSync userId now pause
-
--- dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX
--- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $
---     maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid)
---   where
---     processKnown Entity{entityVal=UserAvs{userAvsUser=uid}} = workJobSychronizeAvs uid pause
---     insertUnknown = void $ maybeCatchAll $ Just <$> upsertAvsUserById apid
-
--- dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX
--- dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ workJobSychronizeAvs uid pause
-
--- workJobSychronizeAvs :: UserId -> Maybe Day -> Handler ()
--- workJobSychronizeAvs uid pause = do
---     now <- liftIO getCurrentTime
---     -- void $ E.upsert
---     --   AvsSync { avsSyncUser         = uid
---     --           , avsSyncCreationTime = now
---     --           , avsSyncPause        = pause
---     --           }
---     --   [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308
---     runDB $ maybeM
---       (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause})
---       (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} ->
---         update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now])
---       (getBy $ UniqueAvsSyncUser uid)
---     void $ queueJob JobSynchroniseAvsQueue
-
-
--- dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
--- dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
---     (unlinked,linked) <- runDB $ do
---       jobs <- E.select (do
---           (avsSync :& usrAvs) <- E.from $  E.table @AvsSync
---                               `E.leftJoin` E.table @UserAvs
---             `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
---           let pause    = avsSync E.^. AvsSyncPause
---               lastSync = usrAvs  E.?. UserAvsLastSynch
---           E.where_ $  E.isNothing pause
---                 E.||. E.isNothing lastSync
---                 E.||. pause E.>. E.dayMaybe lastSync
---           return (avsSync E.^. AvsSyncId, avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId)
---         )
---       let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs
---       E.deleteWhere [AvsSyncId <-. syncIds]
---       return (unlinked, linked)
-
---     void $ updateAvsUserByIds  linked
---     void $ linktoAvsUserByUIDs unlinked
---     -- we do not reschedule failed synchs here in order to avoid a loop
---   where
---     discernJob (accSync, accUid, accApi) (E.Value k,           _, E.Value (Just api)) = (k:accSync, accUid, Set.insert api accApi)
---     discernJob (accSync, accUid, accApi) (E.Value k, E.Value uid, E.Value  Nothing  ) = (k:accSync, Set.insert uid accUid, accApi)
-
-dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
-dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
-    jobs <- runDBRead $ do
-      E.select (do
-          (avsSync :& usrAvs) <- E.from $  E.table @AvsSync
-                              `E.leftJoin` E.table @UserAvs
-            `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
-          let pause    = avsSync E.^. AvsSyncPause
-              lastSync = usrAvs  E.?. UserAvsLastSynch
-              proceed  =        E.isNothing pause
-                          E.||. E.isNothing lastSync
-                          E.||. pause E.>. E.dayMaybe lastSync
-          -- E.where_ proceed -- we still want to delete all paused jobs, rather than to delay them only
-          return (avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId, proceed)
-        )
-      -- now <- liftIO getCurrentTime
-      -- E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
-      -- return jobs
-    let (unlinked, linked) = foldl' discernJob mempty jobs
-    $logInfoS "SynchronisAvs" [st|AVS synch start for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
-    void $ updateAvsUserByIds  linked
-    void $ linktoAvsUserByUIDs unlinked
-    runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)]
-    $logInfoS "SynchronisAvs" [st|AVS synch end for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
-    -- we do not reschedule failed synchs here in order to avoid a loop
-  where
-    discernJob accs (         _ , E.Value (Just api), E.Value True  ) = accs & over _2 (Set.insert api)
-    discernJob accs (E.Value uid, E.Value  Nothing  , E.Value True  ) = accs & over _1 (Set.insert uid)
-    discernJob accs (         _ ,                 _ , E.Value False ) = accs
-
-
------------------
--- AVS Licences
-
-dispatchJobSynchroniseAvsLicences :: JobHandler UniWorX
--- dispatchJobSynchroniseAvsLicences = error "TODO"
-dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel > 0) $ do
-  AvsLicenceSynchConf
-    { avsLicenceSynchLevel        = synchLevel   -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
-    , avsLicenceSynchReasonFilter = reasonFilter
-    , avsLicenceSynchMaxChanges   = maxChanges
-    } <- getsYesod $ view _appAvsLicenceSynchConf
-
-  let procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Handler ()
-      procLic aLic up apids
-        | n <- Set.size apids, n > 0 =
-          let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
-              logit errm = runDB $ logInterface' "AVS" subtype False (isNothing errm) (Just n) (fromMaybe "Automatic synch" errm)
-              catchAllAvs = flip catch (\err -> logit (Just $ tshow (err :: SomeException)) >> return (-1))
-          in if NTop (Just n) <= NTop maxChanges
-              then do
-                oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
-                when (oks > 0) $ logit $ toMaybe (oks /= n) [st|Only #{tshow oks}/#{tshow n} licence changes accepted by AVS|]
-              else
-                logit $ Just [st|Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}|]
-        | otherwise = return ()
-
-  (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
-  -- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
-  reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
-    now <- liftIO getCurrentTime
-    firmBlocks <- runDBRead $ E.select $ do
-      (uavs :& _qualUser :& qblock) <- E.from $ E.table @UserAvs
-        `E.innerJoin` E.table @QualificationUser      `E.on` (\(uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
-        `E.innerJoin` E.table @QualificationUserBlock `E.on` (\(_uavs :& qualUser :& qblock) ->
-            qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
-            E.&&. qblock `isLatestBlockBefore'` E.val now)
-      E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
-          E.&&.  uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
-      return $ uavs E.^. UserAvsPersonId
-    return $ Set.fromList $ map E.unValue firmBlocks
-
-  let fltrIds
-        | synchLevel >= 5 = id
-        | synchLevel >= 3 = flip Set.difference   reasonFltrdIds
-        | otherwise       = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
-
-  when (synchLevel >= 1) $ procLic AvsNoLicence       False $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
-  when (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld
-  when (synchLevel >= 3) $ procLic AvsLicenceVorfeld  False $ fltrIds avsLicenceDiffRevokeRollfeld   --downgrade Rollfeld -> Vorfeld
-  when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True  $ fltrIds avsLicenceDiffGrantRollfeld    --grant     Rollfeld
-
-
--- | delayed exection of already received contact info
-dispatchJobSynchroniseByAvsDataContact :: AvsDataContact -> JobHandler UniWorX
-dispatchJobSynchroniseByAvsDataContact adc =
-  JobHandlerException . runDB . void $ updateAvsUserByADC adc

backend/src/Model/Types/User.hs

@@ -1,70 +0,0 @@
--- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Model.Types.User where
-
-import Import.NoModel
-import Model.Types.TH.PathPiece
-
-
-type UserEduPersonPrincipalName = Text
-
-
-data SystemFunction
-  = SystemExamOffice
-  | SystemFaculty
-  | SystemStudent
-  | SystemPrinter
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
-  deriving anyclass (Universe, Finite, Hashable, NFData)
-
-nullaryPathPiece ''SystemFunction $ camelToPathPiece' 1
-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" -- Brille notwendig
-
-instance RenderMessage a UserDrivingPermit where
-  renderMessage _foundation _languages = tshow
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 3
-  } ''UserDrivingPermit
-derivePersistFieldJSON ''UserDrivingPermit
-nullaryPathPiece ''UserDrivingPermit $ camelToPathPiece' 3
-
-data UserEyeExam = UserEyeExamSX
-                 | UserEyeExamS01
-  deriving (Eq, Ord, Enum, Bounded, Generic, Universe, Finite, Hashable, NFData)
-
-instance Show UserEyeExam where
-  show UserEyeExamSX  = "SX"
-  show UserEyeExamS01 = "S01" -- Brille notwendig
-
-instance RenderMessage a UserEyeExam where
-  renderMessage _foundation _languages = tshow
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 3
-  } ''UserEyeExam
-derivePersistFieldJSON ''UserEyeExam
-nullaryPathPiece ''UserEyeExam $ camelToPathPiece' 3
-
-eyeExamFitsDrivingPermit :: UserEyeExam -> UserDrivingPermit -> Bool
-eyeExamFitsDrivingPermit UserEyeExamSX  _                    = True
-eyeExamFitsDrivingPermit UserEyeExamS01 UserDrivingPermitB01 = True
-eyeExamFitsDrivingPermit _              _                    = False

backend/src/Utils/Avs.hs

@@ -1,271 +0,0 @@
--- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@frapor.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-
-module Utils.Avs where
-
-import Import.NoModel
-import Utils.Lens
-
-import qualified Data.Set           as Set
-import qualified Data.Map           as Map
-import qualified Data.Text          as Text
-
-import Servant
-import Servant.Client
-
-#ifndef DEVELOPMENT
-import Servant.Client.Core (requestPath)
-import UnliftIO.Concurrent (threadDelay)
-#endif
-
-import Model.Types.Avs
-
-
--------------
--- AVS API --
--------------
-type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSPersonContact :<|> AVSGetRampLicences :<|> AVSSetRampLicences)
-type AVSPersonSearch    = "PersonSearch"            :> ReqBody '[JSON] AvsQueryPerson       :> Post '[JSON] AvsResponsePerson
-type AVSPersonStatus    = "PersonStatus"            :> ReqBody '[JSON] AvsQueryStatus       :> Post '[JSON] AvsResponseStatus
-type AVSPersonContact   = "InfoPersonContact"       :> ReqBody '[JSON] AvsQueryContact      :> Post '[JSON] AvsResponseContact
-type AVSGetRampLicences = "RampDrivingLicenceInfo"  :> ReqBody '[JSON] AvsQueryGetLicences  :> Post '[JSON] AvsResponseGetLicences
-type AVSSetRampLicences = "RampDrivingLicence"      :> ReqBody '[JSON] AvsQuerySetLicences  :> Post '[JSON] AvsResponseSetLicences
-
-avsMaxSetLicenceAtOnce :: Int
-avsMaxSetLicenceAtOnce = 80   -- maximum input set size for avsQuerySetLicences as enforced by AVS (<80)
-
-avsMaxQueryAtOnce :: Int
-avsMaxQueryAtOnce = 250       -- maximum input set size for avsQueryStatus and avsQueryContact as enforced by AVS (<500)
-
-avsMaxQueryDelay :: Int
-avsMaxQueryDelay = 200000     -- microsecond to wait before sending another AVS query
-
-
-avsApi :: Proxy AVS
-avsApi = Proxy
-
-{-
--- Somehow the GADT-style declaration is not flexible enough to compile at the location of the function call
-data AvsQuery where
-  AvsQuery :: { avsQueryPerson :: MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
-              , avsQueryStatus :: MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
-              ...
-              }
-      -> AvsQuery
--}
-
-data AvsQuery = AvsQuery
-  { avsQueryPerson         :: forall m. MonadIO m => AvsQueryPerson      -> m (Either ClientError AvsResponsePerson)
-  , avsQueryStatus         :: forall m. MonadIO m => AvsQueryStatus      -> m (Either ClientError AvsResponseStatus)
-  , avsQueryContact        :: forall m. MonadIO m => AvsQueryContact     -> m (Either ClientError AvsResponseContact)
-  , avsQuerySetLicences    :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences)
-  -- , avsQueryGetLicences    :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) -- not supported by VSM
-  , avsQueryGetAllLicences :: forall m. MonadIO m =>                        m (Either ClientError AvsResponseGetLicences)
-  }
-
-makeLenses_ ''AvsQuery
-
-
--- | AVS/VSM-interface currently only allows GetLicences with query argument ID 0, which means all licences; all other queries yield an empty response
-avsQueryAllLicences :: AvsQueryGetLicences
-avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
-
-
-mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
-#ifdef DEVELOPMENT
-mkAvsQuery _ _ _ = AvsQuery
-    { avsQueryPerson          =       return . Right . fakePerson
-    , avsQueryStatus          =       return . Right . fakeStatus
-    , avsQueryContact         =       return . Right . fakeContact
-    , avsQuerySetLicences     = \_ -> return . Right $ AvsResponseSetLicences mempty
-    , avsQueryGetAllLicences  =       return . Right $ AvsResponseGetLicences mempty
-    }
-  where
-    fakeCard1 = AvsDataPersonCard True  (Just $ fromGregorian 2026 5 1) Nothing AvsCardColorGelb  (Set.fromList ['F','R','C']) Nothing Nothing Nothing (Just "Fraport AG")                              (AvsCardNo "6666") "4"
-    fakeCard2 = AvsDataPersonCard False (Just $ fromGregorian 2025 6 2) Nothing AvsCardColorRot   (Set.fromList ['F','A' ])    Nothing Nothing Nothing (Just "N*ICE Aircraft Services & Support GmbH")  (AvsCardNo "7777") "4" -- AVSneo will report multiple companies using multiple cards with same card no
-    fakeCard3 = AvsDataPersonCard True  (Just $ fromGregorian 2028 7 3) Nothing AvsCardColorBlau  mempty                       Nothing Nothing Nothing (Just "Fraport Facility Services GmbH")          (AvsCardNo "7777") "4"
-    fakeCard4 = AvsDataPersonCard True  (Just $ fromGregorian 2028 7 3) Nothing AvsCardColorGrün  mempty                       Nothing Nothing Nothing (Just "Vollautomaten GmbH")                      (AvsCardNo "7777") "4"
-
-    fakePerson :: AvsQueryPerson -> AvsResponsePerson
-    fakePerson =
-      let
-        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) $ Set.fromList [fakeCard1, fakeCard2]
-        steffen  = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) $ Set.fromList [fakeCard2, fakeCard3, fakeCard4]
-        sumpfi1  = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty
-        sumpfi2  = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) $ Set.fromList [fakeCard1, fakeCard2, fakeCard3, fakeCard4]
-        sumpfi3  = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty
-      in \case
-        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234"), avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson steffen
-        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234")}                                    -> AvsResponsePerson steffen
-        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00009944"), avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson stephan
-        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00003344"), avsPersonQueryVersionNo=Just "1"}  -> AvsResponsePerson sarah
-        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "34")}                                          -> AvsResponsePerson $ steffen <> sarah
-        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "4")       , avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson $ steffen <> stephan
-        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00006666"), avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
-        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00007777"), avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
-        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo     "7777"), avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
-        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00008888"), avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
-        _ -> AvsResponsePerson $ steffen <> sumpfi1
-
-    fakeStatus :: AvsQueryStatus -> AvsResponseStatus
-    fakeStatus (AvsQueryStatus (Set.toList -> (api:_))) = AvsResponseStatus $ Set.singleton $ AvsStatusPerson api $ Set.fromList [fakeCard1, fakeCard2, fakeCard3, fakeCard4]
-    fakeStatus  _ = AvsResponseStatus mempty
-    fakeContact :: AvsQueryContact -> AvsResponseContact
-    fakeContact (AvsQueryContact (Set.toList -> ((AvsObjPersonId api):_)))
-      | api == AvsPersonId 12345678   = AvsResponseContact $ Set.singleton jost
-      | api == AvsPersonId  2         = AvsResponseContact $ Set.singleton vaupel
-      | api == AvsPersonId    4       = AvsResponseContact $ Set.singleton barth
-      | api == AvsPersonId 12345678   = AvsResponseContact $ Set.singleton heribert
-      | api == AvsPersonId 604387     = AvsResponseContact $ Set.singleton heribert
-      | api == AvsPersonId 604591     = AvsResponseContact $ Set.singleton heribert
-      | otherwise                     = AvsResponseContact   mempty
-      where
-        heribert = AvsDataContact api (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing (Just "sumpfi@tcs.ifi.lmu.de") Nothing (Just $ AvsInternalPersonalNo "57138"))
-                                      (AvsFirmInfo "Fraport AG" 7 "Fraport" Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
-        jost     = AvsDataContact api (AvsPersonInfo "12345678"  "Steffen"  "Jost"         0  Nothing (Just "s.jost@fraport.de")     (Just "069-69071706") Nothing)
-                                      (AvsFirmInfo "Fraport AG" 7 "Fraport" Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
-        vaupel   = AvsDataContact api (AvsPersonInfo "2"         "Sarah"  "Vaupel"         1  Nothing (Just "sarah.vaupel@uniworx.de")     (Just "069-69071706") Nothing)
-                                      (AvsFirmInfo "UniWorX GmbH" 9 "UniWorX" (Just "81929") (Just "München") (Just "Germany") (Just "Somestr. 111") (Just "uniworx@uniworx.de") Nothing Nothing)
-        barth    = AvsDataContact api (AvsPersonInfo "4"          "Stephan"  "Barth"         2  Nothing (Just "stephan.barth@uniworx.de")     (Just "069-69071706") Nothing)
-                                      (AvsFirmInfo "UniWorX GmbH" 9 "UniWorX" Nothing Nothing Nothing Nothing Nothing (Just "sarah.vaupel@uniworx.de") Nothing)
-    fakeContact _ = AvsResponseContact mempty
-#else
-mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
-    { avsQueryPerson      = \q -> if q == def then return $ Right $ AvsResponsePerson mempty else -- prevent empty queries
-                                  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 -- NOTE: 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
-    }
-  where
-    (       rawQueryPerson
-      :<|>  rawQueryStatus
-      :<|>  rawQueryContact
-      :<|>  rawQueryGetLicences
-      :<|>  rawQuerySetLicences )  = client avsApi basicAuth
-    catch404toEmpty :: Either ClientError AvsResponsePerson -> Either ClientError AvsResponsePerson
-    catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404)))
-      | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
-    catch404toEmpty other = other
-
-splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Monoid (Unwrapped c))
-            => (a -> ClientM c) -> a -> ClientM c
-splitQuery rawQuery q
-    | Set.size s <= 0 = return $ view _Unwrapped' mempty      -- empty query, retun empty answer
-    | avsMaxQueryAtOnce >= Set.size s = rawQuery q
-    | otherwise = do
-        --  logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s) -- would require MonadLogger ClientM
-        let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s
-        res1 <-            rawQuery $ view _Unwrapped' avsid1
-        liftIO $ threadDelay avsMaxQueryDelay
-        res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2
-        return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped')
-  where
-    s = view _Wrapped' q
-#endif
-
------------------------
--- Utility Functions -- DEPRECTATED
------------------------
-
---   retrieve AvsDataPersonCard with longest validity for a given licence,
---   first argument is a lower bound for avsDataValidTo, usually current day
---   Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case)
--- getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard
--- getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
---   where
---     licence = licence2char licence'
---     validLicenceCards = Set.filter cardMatch cards
---     cardMatch AvsDataPersonCard{..} =
---       avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
-
--- -- DEPRECTATED
--- getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
--- getCompanyAddress card@AvsDataPersonCard{..}
---   | Just street <- avsDataStreet
---   , Just pcode  <- avsDataPostalCode
---   , Just city   <- avsDataCity
---     = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card)
---   | isJust avsDataFirm = (avsDataFirm, Nothing, Just card)
---   | otherwise = (Nothing, Nothing, Nothing)
-
--- --   From a set of card, choose the one with the most complete postal address.
--- --   Returns company, postal address and the associated card where the address was taken from
--- guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
--- guessLicenceAddress cards
---   | Just c <- Set.lookupMax cards
---   , card <- Set.foldr pickLicenceAddress c cards
---     = getCompanyAddress card
---   | otherwise = (Nothing, Nothing, Nothing)
-
--- hasAddress :: AvsDataPersonCard -> Bool
--- hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
-
--- pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
--- pickLicenceAddress a b
---     | Just r <- pickBetter' hasAddress                                      = r   -- prefer card with complete address
---     | Just r <- pickBetter' avsDataValid                                    = r   -- prefer valid cards
---     | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r   -- prefer 'R' cards
---     | Just r <- pickBetter' (Set.member licenceVorfeld  . avsDataCardAreas) = r   -- prefer 'F' cards
---     | avsDataCardColor a > avsDataCardColor b                               = a   -- prefer Yellow over Green, etc.
---     | avsDataCardColor a < avsDataCardColor b                               = b
---     | avsDataIssueDate a > avsDataIssueDate b                               = a   -- prefer later issue date
---     | avsDataIssueDate a < avsDataIssueDate b                               = b
---     | avsDataValidTo   a > avsDataValidTo   b                               = a   -- prefer later validto date
---     | avsDataValidTo   a < avsDataValidTo   b                               = b
---     | Just r <- pickBetter' (isJust . avsDataFirm)                          = r   -- prefer having a firm
---     | a <= b    = b -- respect natural Ord instance
---     | otherwise = a
---   where
---     pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
---     pickBetter' = pickBetter a b
---     licenceRollfeld = licence2char AvsLicenceRollfeld
---     licenceVorfeld  = licence2char AvsLicenceVorfeld
-
--- {- Note:
--- For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so
--- bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
---   compare a b =  compareBy avsDataValid
---               <> compareBy avsDataValidTo
---               <> compareBy avsDataIssueDate
---               ...
---     where
---       compareBy f = compare `on` f a b
--- -}
-
--- Merges several answers by AvsPersonId, preserving all AvsPersonCards
-mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
-mergeByPersonId = flip $ Set.foldr aux
-  where
-    aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
-    aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp
-
-catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson
-catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp
-
-mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
-mergeAvsDataPerson = Map.unionWithKey merger
-  where
-    merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
-    merger api pa pb =
-      let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
-          pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
-      in AvsDataPerson
-        { avsPersonFirstName          = pickBy' Text.length avsPersonFirstName
-        , avsPersonLastName           = pickBy' Text.length avsPersonLastName
-        , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo
-        , avsPersonPersonNo           = pickBy' id avsPersonPersonNo
-        , avsPersonPersonID           = api -- keys must be identical due to call with insertWithKey
-        , avsPersonPersonCards        = (Set.union `on` avsPersonPersonCards) pa pb
-        }
-
-    pickBy :: Ord b => (a -> b) -> a -> a -> a
-    pickBy f x y  | f x >= f y = x
-                  | otherwise  = y
-
-

backend/src/Utils/Company.hs

@@ -1,47 +0,0 @@
--- SPDX-FileCopyrightText: 2025 Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Utils.Company where
-
-import Import.NoFoundation
-import Foundation.Type
-import Foundation.DB
-
--- import           Database.Esqueleto.Experimental ((:&)(..))
-import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
-import qualified Database.Esqueleto.Utils        as E
--- import qualified Database.Esqueleto.PostgreSQL   as E
-
-import Handler.Utils.Memcached
-
-
--- DB Queries related to firms and supervision that are used in several places
-
-
--- | check if a user is NOT associated with a company; false if company is null
-usrDoesNotBelong :: E.SqlExpr (E.Value UserId) -> E.SqlExpr (E.Value (Maybe CompanyId)) -> E.SqlExpr (E.Value Bool)
-usrDoesNotBelong uid fsh = E.isJust fsh E.&&. E.notExists (do
-    uc <- E.from $ E.table @UserCompany
-    E.where_ $ uc E.^. UserCompanyUser    E.==. uid
-        E.&&.  uc E.^. UserCompanyCompany E.=?. fsh
-  )
-
--- | given a supervisionship, true if supervisor is NOT associated with the supervisionship-company
-missingCompanySupervisor :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)
-missingCompanySupervisor us = (us E.^. UserSupervisorSupervisor) `usrDoesNotBelong` (us E.^. UserSupervisorCompany)
-
--- | given a supervisionship, true if client is NOT associated with the supervisionship-company
-missingCompanyClient :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)
-missingCompanyClient us = (us E.^. UserSupervisorUser) `usrDoesNotBelong` (us E.^. UserSupervisorCompany)
-
--- | once per day, check if there are supervisionships where supervisor or client are not associated witht the supervisionship-company
-areThereInsaneCompanySupervisions :: HandlerFor UniWorX (Bool, UTCTime)
-areThereInsaneCompanySupervisions = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-company-supervision|] $ do
-  now <- liftIO getCurrentTime
-  res <- runDBRead $ E.selectExists $ do
-    us <- E.from $ E.table @UserSupervisor
-    E.where_ $ E.isJust (us E.^. UserSupervisorCompany)
-        E.&&. (missingCompanySupervisor us E.||. missingCompanyClient us)
-  $logInfoS "sanity" [st|Are there insane company supervisions: #{tshow res}|]
-  return (res,now)

backend/src/Utils/DB.hs

@@ -1,506 +0,0 @@
--- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
--- also see Utils.Persist
-
-module Utils.DB where
-
-import ClassyPrelude.Yesod hiding (addMessageI)
-
-import qualified Data.Monoid as Monoid (First())
-import qualified Data.List as List
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Database.Esqueleto.Legacy as E
-
-import Utils
-import Control.Lens
-import Control.Lens.Extras (is)
-
-import Control.Monad.Catch hiding (bracket)
-
-import qualified Utils.Pool as Custom
-
-import Database.Persist.Sql (runSqlConn) -- , updateWhereCount)
-
-import GHC.Stack (HasCallStack, CallStack, callStack)
-
--- import Language.Haskell.TH.Lift
-
--- import Control.Monad.Fix (MonadFix)
--- import Control.Monad.Fail (MonadFail)
-
--- import Control.Monad.Trans.Reader (withReaderT)
-
--- | Obtain a record projection from an EntityField
-getFieldEnt  :: PersistEntity record => EntityField record typ -> Entity record -> typ
-getFieldEnt = view . fieldLens
-
-getField     :: PersistEntity record => EntityField record typ -> record -> typ
-getField = view . fieldLensVal
-
--- | Obtain a lens from an EntityField
-fieldLensVal :: PersistEntity record => EntityField record typ -> Lens' record typ
-fieldLensVal f = entityLens . fieldLens f
-  where
-    entityLens :: Lens' record (Entity record)
-    entityLens = lens getVal setVal
-    getVal :: record -> Entity record
-    getVal   = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally
-    setVal :: record -> Entity record -> record
-    setVal _ = entityVal
-
-
-emptyOrIn :: PersistField typ
-          => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
-emptyOrIn criterion testSet
-  | Set.null testSet = E.val True
-  | otherwise        = criterion `E.in_` E.valList (Set.toList testSet)
-
-entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
-entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
-
-getJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
-          => Unique record -> ReaderT backend m (Entity record)
-getJustBy u = getBy u >>= maybe
-  (throwM . PersistForeignConstraintUnmet $ tshow u)
-  return
-
-getKeyBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
-         => Unique record -> ReaderT backend m (Maybe (Key record))
-getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
-
-getKeyJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
-             => Unique record -> ReaderT backend m (Key record)
-getKeyJustBy u = getKeyBy u >>= maybe
-  (throwM . PersistForeignConstraintUnmet $ tshow u)
-  return
-
-getKeyBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
-            => Unique record -> ReaderT backend m (Key record)
-getKeyBy404 u = getKeyBy u >>= maybe notFound return
-
-getEntity404 :: (PersistStoreRead backend, PersistRecordBackend record backend, MonadHandler m)
-             => Key record -> ReaderT backend m (Entity record)
-getEntity404 k = Entity k <$> get404 k
-
-notExists :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) => [Filter record] -> ReaderT backend m Bool
-notExists = fmap not . exists
-
-existsBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
-         => Unique record -> ReaderT backend m Bool
-existsBy = fmap (is _Just) . getKeyBy
-
-existsBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
-            => Unique record -> ReaderT backend m ()
-existsBy404 = bool notFound (return ()) <=< fmap (is _Just) . getKeyBy
-
-existsKey :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
-          => Key record -> ReaderT backend m Bool
-existsKey = exists . pure . (persistIdField ==.)
-
--- -- Available in persistent since 2.11.0.0
--- exists :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
---        => [Filter record] -> ReaderT backend m Bool
--- exists = fmap (not . null) . flip selectKeysList [LimitTo 1]
-
-exists404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
-          => [Filter record] -> ReaderT backend m ()
-exists404 = bool (return ()) notFound <=< fmap null . flip selectKeysList [LimitTo 1]
-
-existsKey404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
-             => Key record -> ReaderT backend m ()
-existsKey404 = bool notFound (return ()) <=< existsKey
-
--- | given filter criteria like `selectList` this function returns Just if and only if there is precisely one result
---   getByPeseudoUnique
-getByFilter ::  (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
-            =>  [Filter record] -> ReaderT backend m (Maybe (Entity record))
-getByFilter crit =
-  selectList crit [LimitTo 2] <&> \case
-    [singleEntity] -> Just singleEntity
-    _              -> Nothing -- not existing or not unique
-
-getKeyByFilter ::  (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
-            =>  [Filter record] -> ReaderT backend m (Maybe (Key record))
-getKeyByFilter crit =
-  selectKeysList crit [LimitTo 2] <&> \case
-    [singleKey] -> Just singleKey
-    _           -> Nothing -- not existing or not unique
-
-
-updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
-         => Unique record -> [Update record] -> ReaderT backend m ()
-updateBy uniq updates = do
-  key <- getKeyBy uniq
-  for_ key $ flip update updates
-
--- | update and retrieve an entity. Will throw an error if the key is updaded
-updateGetEntity :: (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m (Entity record)
-updateGetEntity k = fmap (Entity k) . updateGet k
-
--- | insert or replace a record based on a single uniqueness constraint
---   this function was meant to be supplied with the uniqueness constraint, but it would be unsafe if the uniqueness constraint would not match the supplied record
-replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend)
-              => record -> ReaderT backend m ()
-replaceBy r = do
-  u <- onlyUnique r
-  deleteBy u
-  insert_ r
-
--- | Like 'myReplaceUnique' or 'replaceUnique' but with reversed result: returns 'Nothing' if the replacement was not possible,
---   and 'Just key' for the successfully replaced record
-uniqueReplace :: ( MonadIO m
-                 , Eq (Unique record)
-                 , PersistRecordBackend record backend
-                 , PersistUniqueWrite backend
-                 )
-              => Key record -> record -> ReaderT backend m (Maybe (Key record))
-uniqueReplace key datumNew = flipMaybe key <$> myReplaceUnique key datumNew
-
--- | Identical to 'Database.Persist.Class', except for the better type signature (original requires Eq  record which is not needed anyway)
-myReplaceUnique :: ( MonadIO m
-                   , Eq (Unique record)
-                   , PersistRecordBackend record backend
-                   , PersistUniqueWrite backend
-                   )
-                => Key record -> record -> ReaderT backend m (Maybe (Unique record))
-myReplaceUnique key datumNew = getJust key >>= replaceOriginal
-  where
-    uniqueKeysNew = persistUniqueKeys datumNew
-    replaceOriginal original = do
-        conflict <- checkUniqueKeys changedKeys
-        case conflict of
-            Nothing -> replace key datumNew >> return Nothing
-            (Just conflictingKey) -> return $ Just conflictingKey
-      where
-        changedKeys = uniqueKeysNew List.\\ uniqueKeysOriginal
-        uniqueKeysOriginal = persistUniqueKeys original
-
-replaceEntity :: ( MonadIO m
-                 , PersistRecordBackend record backend
-                 , PersistStoreWrite backend
-                 )
-              => Entity record -> ReaderT backend m ()
-replaceEntity Entity{..} = replace entityKey entityVal
-
--- Notes on upsertBy:
---  * Unique denotes old record
---  * Changes to fields involved in uniqueness work, but may throw an error if updated record already exists
---  * Use Database.Esqueleto.PostgreSQL.upsertBy for more elaborate conflict updates
-
--- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint
-upsertBySafe :: ( MonadIO m
-                , PersistEntity record
-                , PersistUniqueWrite backend
-                , PersistEntityBackend record ~ BaseBackend backend
-                )
-             => Unique record -> record -> (record -> record) -> ReaderT backend m (Maybe (Key record))
-upsertBySafe uniq newr upd = maybeM (insertUnique newr) do_upd (getBy uniq)
-  where
-    do_upd Entity{entityKey = oid, entityVal = oldr} = do
-      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
-                   , PersistRecordBackend record backend
-                   )
-                => [Unique record] -> ReaderT backend m (Maybe (Unique record))
-checkUniqueKeys [] = return Nothing
-checkUniqueKeys (x:xs) = do
-    y <- getBy x
-    case y of
-        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
-       , PersistRecordBackend record backend
-       )
-    => record -> ReaderT backend m (Key record)
--- ^ `insert`, but remove all records with matching uniqueness constraints first
-put v = do
-  forM_ (persistUniqueKeys v) deleteBy
-  insert v
-
--- | Deprecated, use selectFirst instead.
-selectMaybe :: forall record backend m.
-               ( MonadIO m
-               , PersistQueryRead backend
-               , PersistRecordBackend record backend
-               )
-            => [Filter record] -> [SelectOpt record]
-            -> ReaderT backend m (Maybe (Entity record))
-selectMaybe fltrs opts = listToMaybe <$> selectList fltrs (LimitTo 1 : opts')
-  where opts' = filter (not . isLimit) opts
-        isLimit = \case
-          LimitTo _ -> True
-          _other    -> False
-
-
-type DBConnLabel = CallStack
-
-customRunSqlPool :: (HasCallStack, MonadUnliftIO m, BackendCompatible SqlBackend backend)
-                 => ReaderT backend m a
-                 -> Custom.Pool' m DBConnLabel c backend
-                 -> m a
-customRunSqlPool act p = customRunSqlPool' act p callStack
-
-customRunSqlPool' :: (MonadUnliftIO m, BackendCompatible SqlBackend backend)
-                  => ReaderT backend m a
-                  -> Custom.Pool' m DBConnLabel c backend
-                  -> CallStack
-                  -> m a
-customRunSqlPool' act p label = Custom.withResource' p label $ runSqlConn act
-
-
-class WithRunDB backend m' m | m -> backend m' where
-  useRunDB :: ReaderT backend m' a -> m a
-
-instance WithRunDB backend m (ReaderT backend m) where
-  useRunDB = id
-
--- Could be used at Handler.Admin.postAdminProblemsR, but not yet elsewhere, thus inlined for now, as it may be too special:
--- updateWithMessage
---   :: ( YesodPersist site, PersistEntity val, BackendCompatible SqlBackend (YesodPersistBackend site), PersistEntityBackend val ~ SqlBackend
---       , Num a, Ord a, RenderMessage site msg, RedirectUrl site (url,[(Text,Text)]))
---   => url                 -- where to redirect, if changes were mage
---   -> [Filter val]        -- update filter
---   -> [Update val]        -- actual update
---   -> a                   -- expected updates
---   -> (a -> msg)          -- message to add with number of actual changes
---   -> HandlerFor site ()
--- updateWithMessage route flt upd no_req msg = do
---   (fromIntegral -> oks) <- runDB $ updateWhereCount flt upd
---   let mkind = if oks < no_req || no_req <= 0 then Warning else Success
---   addMessageI mkind $ msg oks
---   when (oks > 0) $ do -- reload to ensure updates are displayed
---     getps <- reqGetParams <$> getRequest
---     redirect (route, getps)
-
-
--- newtype DBRunner' backend m = DBRunner' { runDBRunner' :: forall b. ReaderT backend m b -> m b }
-
--- _DBRunner' :: Iso' (DBRunner site) (DBRunner' (YesodPersistBackend site) (HandlerFor site))
--- _DBRunner' = iso fromDBRunner' toDBRunner
---   where
---     fromDBRunner' :: forall site.
---                      DBRunner site
---                   -> DBRunner' (YesodPersistBackend site) (HandlerFor site)
---     fromDBRunner' DBRunner{..} = DBRunner' runDBRunner
-
---     toDBRunner :: forall site.
---                   DBRunner' (YesodPersistBackend site) (HandlerFor site)
---                -> DBRunner site
---     toDBRunner DBRunner'{..} = DBRunner runDBRunner'
-
--- fromDBRunner :: BackendCompatible backend (YesodPersistBackend site) => DBRunner site -> DBRunner' backend (HandlerFor site)
--- fromDBRunner DBRunner{..} = DBRunner' (runDBRunner . withReaderT projectBackend)
-
--- newtype CachedDBRunner backend m a = CachedDBRunner { runCachedDBRunnerUsing :: m (DBRunner' backend m) -> m a }
---   deriving (Functor, Applicative, Monad, MonadFix, MonadFail, Contravariant, MonadIO, Alternative, MonadPlus, MonadUnliftIO, MonadResource, MonadLogger, MonadThrow, MonadCatch, MonadMask) via (ReaderT (m (DBRunner' backend m)) m)
-
--- instance MonadTrans (CachedDBRunner backend) where
---   lift act = CachedDBRunner (const act)
-
--- instance MonadHandler m => MonadHandler (CachedDBRunner backend m) where
---   type HandlerSite (CachedDBRunner backend m) = HandlerSite m
---   type SubHandlerSite (CachedDBRunner backend m) = SubHandlerSite m
-
---   liftHandler = lift . liftHandler
---   liftSubHandler = lift . liftSubHandler
-
--- instance Monad m => WithRunDB backend m (CachedDBRunner backend m) where
---   useRunDB act = CachedDBRunner (\getRunner -> getRunner >>= \DBRunner'{..} -> runDBRunner' act)
-
--- runCachedDBRunnerSTM :: MonadUnliftIO m
---                      => m (DBRunner' backend m)
---                      -> CachedDBRunner backend m a
---                      -> m a
--- runCachedDBRunnerSTM doAcquire act = do
---   doAcquireLock <- newTMVarIO ()
---   runnerTMVar <- newEmptyTMVarIO
-
---   let getRunner = bracket (atomically $ takeTMVar doAcquireLock) (void . atomically . tryPutTMVar doAcquireLock) . const $ do
---         cachedRunner <- atomically $ tryReadTMVar runnerTMVar
---         case cachedRunner of
---           Just cachedRunner' -> return cachedRunner'
---           Nothing -> do
---             runner <- doAcquire
---             void . atomically $ tryPutTMVar runnerTMVar runner
---             return runner
---       getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar)
-
---   runCachedDBRunnerUsing act getRunnerNoLock
-
-
-
--- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens
-data CheckUpdate record iraw =
-    forall typ. (Eq typ, PersistField typ) =>
-    CheckUpdate     (EntityField record typ) (Getting               typ  iraw typ) -- A persistent record field and fitting getting (also use for typ ~ Maybe typ')
-  | forall typ. (Eq typ, PersistField typ) =>
-    CheckUpdateMay  (EntityField record (Maybe typ)) (Getting (Maybe typ) iraw (Maybe typ)) -- Special case, when `typ` is optional everywhere, forces update of Nothing to Just values
-  | forall typ. (Eq typ, PersistField typ) =>
-    CheckUpdateOpt  (EntityField record typ) (Getting (Monoid.First typ) iraw typ) -- Special case, when `typ` is optional for the lens, but not optional in DB.
-
--- deriving instance Lift (CheckUpdate record iraw) -- not possible, seee Handler.Utils.AvsUpdate for a workaround
--- instance Lift (CheckUpdate record iraw) where
---   lift = $(makeLift ''CheckUpdate)
-
--- | checks if an update would be performed, if a new different value would be presented. Should agree with `mkUpdate` familiy of functions
-mayUpdate :: PersistEntity record => record -> Maybe iraw -> CheckUpdate record iraw -> Bool
-mayUpdate ent (Just old) (CheckUpdate up l)
-  | let oldval = old ^. l
-  , let entval = ent ^. fieldLensVal up
-    = oldval == entval
-mayUpdate ent (Just old) (CheckUpdateMay up l)
-  | let oldval = old ^. l
-  , let entval = ent ^. fieldLensVal up
-    = isNothing entval || oldval == entval
-mayUpdate ent (Just old) (CheckUpdateOpt up l)
-  | Just oldval <- old ^? l
-  , let entval = ent ^. fieldLensVal up
-    = oldval == entval
-mayUpdate _ _ _ = False
-
--- | Compute necessary updates. Given a database record, the new and old raw data, and a pair consisting of a getter from raw data to a value and an EntityField of the same value,
---   an update is returned, if the current value is identical to the old value, which changed in the new raw data
-mkUpdate :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record)
-mkUpdate ent new (Just old) (CheckUpdate up l)
-  | let newval = new ^. l
-  , let oldval = old ^. l
-  , let entval = ent ^. fieldLensVal up
-  , newval /= entval
-  , oldval == entval
-    = Just (up =. newval)
-mkUpdate ent new (Just old) (CheckUpdateMay up l)
-  | let newval = new ^. l
-  , let oldval = old ^. l
-  , let entval = ent ^. fieldLensVal up
-  , (isNothing entval && isJust newval) || (newval /= entval && oldval == entval)
-    = Just (up =. newval)
-mkUpdate ent new (Just old) (CheckUpdateOpt up l)
-  | Just newval <- new ^? l
-  , Just oldval <- old ^? l
-  , let entval = ent ^. fieldLensVal up
-  , newval /= entval
-  , oldval == entval
-    = Just (up =. newval)
-mkUpdate _ _ _ _ = Nothing
-
--- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited
-mkUpdate' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record)
-mkUpdate' ent new Nothing = mkUpdateDirect ent new
-mkUpdate' ent new just    = mkUpdate       ent new just
-
--- | Like `mkUpdate` but performs the update without comparison to a previous older value, whenever current entity value and new value are different
-mkUpdateDirect :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> Maybe (Update record)
-mkUpdateDirect ent new (CheckUpdate up l)
-  | let newval = new ^. l
-  , let entval = ent ^. fieldLensVal up
-  , newval /= entval
-    = Just (up =. newval)
-mkUpdateDirect ent new (CheckUpdateMay up l)
-  | let newval = new ^. l
-  , let entval = ent ^. fieldLensVal up
-  , newval /= entval
-    = Just (up =. newval)
-mkUpdateDirect ent new (CheckUpdateOpt up l)
-  | Just newval <- new ^? l
-  , let entval = ent ^. fieldLensVal up
-  , newval /= entval
-    = Just (up =. newval)
-mkUpdateDirect _ _ _ = Nothing
-
--- | Unconditionally update a record through CheckUpdate
-updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record
-updateRecord ent new (CheckUpdate up l) =
-  let newval  = new ^. l
-      lensRec = fieldLensVal up
-  in  ent & lensRec .~ newval
-updateRecord ent new (CheckUpdateMay up l) =
-  let newval  = new ^. l
-      lensRec = fieldLensVal up
-  in  ent & lensRec .~ newval
-updateRecord ent new (CheckUpdateOpt up l)
-  | Just newval <- new ^? l
-    = ent & fieldLensVal up .~ newval
-  | otherwise
-    = ent
-
--- | like mkUpdate' but only returns the update if the new value would be unique
--- mkUpdateCheckUnique' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> DB (Maybe (Update record))
-mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend)
-                    => record -> a -> Maybe a -> CheckUpdate record a -> ReaderT backend m (Maybe (Update record))
-mkUpdateCheckUnique' ent new Nothing (CheckUpdate up l)
-  | let newval = new ^. l
-  , let entval = ent ^. fieldLensVal up
-  , newval /= entval
-    = do
-        newval_exists <- exists [up ==. newval]
-        return $ toMaybe (not newval_exists) (up =. newval)
-mkUpdateCheckUnique' ent new Nothing (CheckUpdateMay up l)
-  | let newval = new ^. l
-  , let entval = ent ^. fieldLensVal up
-  , newval /= entval
-    = do
-        newval_exists <- exists [up ==. newval]
-        return $ toMaybe (not newval_exists) (up =. newval)
-mkUpdateCheckUnique' ent new Nothing (CheckUpdateOpt up l)
-  | Just newval <- new ^? l
-  , let entval = ent ^. fieldLensVal up
-  , newval /= entval
-    = do
-        newval_exists <- exists [up ==. newval]
-        return $ toMaybe (not newval_exists) (up =. newval)
-mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l)
-  | let newval = new ^. l
-  , let oldval = old ^. l
-  , let entval = ent ^. fieldLensVal up
-  , newval /= entval
-  , oldval == entval
-    = do
-        newval_exists <- exists [up ==. newval]
-        return $ toMaybe (not newval_exists) (up =. newval)
-mkUpdateCheckUnique' ent new (Just old) (CheckUpdateMay up l)
-  | let newval = new ^. l
-  , let oldval = old ^. l
-  , let entval = ent ^. fieldLensVal up
-  , (isNothing entval && isJust newval) || (newval /= entval && oldval == entval)
-    = do
-        newval_exists <- exists [up ==. newval]
-        return $ toMaybe (not newval_exists) (up =. newval)
-mkUpdateCheckUnique' ent new (Just old) (CheckUpdateOpt up l)
-  | Just newval <- new ^? l
-  , Just oldval <- old ^? l
-  , let entval = ent ^. fieldLensVal up
-  , newval /= entval
-  , oldval == entval
-    = do
-        newval_exists <- exists [up ==. newval]
-        return $ toMaybe (not newval_exists) (up =. newval)
-mkUpdateCheckUnique' _ _ _ _ = return Nothing

backend/src/Utils/Mail.hs

@@ -1,102 +0,0 @@
--- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Utils.Mail where
-
-
-import Import.NoModel
-
-import qualified Data.Char          as Char
-import qualified Data.Text as Text
-import qualified Data.CaseInsensitive as CI
-
-import qualified Text.Email.Validate as Email
-
--- | domains used by LDAP accounts
-fraportMailDomains :: [Text]
-fraportMailDomains = ["@fraport.de"] -- <&> foldCase only!
-
--- | returns the part before the @ symbol of an email address that ends with a fraport domain, preserving case
---   eg. getFraportLogin "E1234@fraport.de"     == Just "E1234" 
---       getFraportLogin "S.Guy@fraport.de"     == Just "S.Guy"
---       getFraportLogin "S.Guy@elsewhere.com"  == Nothing
---   Use CI.traverse getFraportLogin :: CI Text -> Maybe (CI Text)
---       CI.traverse getFraportLogin "S.Jost@Fraport.de" == Just "S.Jost" 
-getFraportLogin :: Text -> Maybe Text
-getFraportLogin email = orgCase <$> lowerCaseLogin
-  where 
-    orgCase         = flip Text.take email . Text.length
-    lowerCaseLogin  = firstJust (flip Text.stripSuffix $ foldCase email) fraportMailDomains
-
--- | check that an email is valid and that it is not an E-account that nobody reads
--- also see `Handler.Utils.Users.getUserEmail` for Tests accepting User Type
-validEmail :: Text -> Bool      -- Email = Text
-validEmail email = validRFC5322 && not invalidFraport
-  where 
-    validRFC5322 = Email.isValid $ encodeUtf8 email
-    invalidFraport = case getFraportLogin email of
-      Just fralogin -> Text.all Char.isDigit $ Text.drop 1 fralogin          -- Emails like E1234@fraport.de or 012345!fraport.de are not read
-      Nothing       -> False
-
-validEmail' :: CI Text -> Bool -- UserEmail = CI Text
-validEmail' = validEmail . CI.original
-
--- | returns the first valid Email, if any
-pickValidEmail :: [Text] -> Maybe Text
-pickValidEmail = find validEmail
-
--- | returns the first valid Email, if any
-pickValidEmail' :: [CI Text] -> Maybe (CI Text)
-pickValidEmail' = find validEmail' 
-
--- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function
-pickValidUserEmail :: CI Text -> CI Text -> CI Text
-pickValidUserEmail x y
-  | validEmail' x = x
-  | otherwise     = y
-
--- | returns first valid email address or none if none are valid
-pickValidUserEmail' :: CI Text -> CI Text -> Maybe (CI Text)
-pickValidUserEmail' x y
-  | validEmail' x = Just x
-  | validEmail' y = Just y
-  | otherwise     = Nothing
-
-
---------------------
--- Telephone Utils
-
--- | normalize phone numbers
-canonicalPhone :: Text -> Text
-canonicalPhone pn
-  | Just pn01 <- Text.stripPrefix "01" pn
-    = german_mobile pn01 
-  | Just pn01 <- Text.stripPrefix "+491" pn
-    = german_mobile pn01
-  | Just pn00 <- Text.stripPrefix "00" pn
-    = Text.cons '+' $ Text.map repl_nondigit pn00
-  | Just ('0', pn0) <- Text.uncons pn
-  , Just (snr,  _ ) <- Text.uncons pn0
-  , snr /= '0'
-  , Char.isDigit snr
-    = "+49 " <> Text.map repl_nondigit pn0
-  | otherwise
-    = Text.map repl_nondigit pn
-  where
-    -- split_area :: Text -> Char -> Int -> Text -> Text
-    -- split_area c f p n =
-    --   let (area,sufx) = Text.splitAt p $ Text.filter Char.isDigit n
-    --   in c <> Text.cons f area <> Text.cons ' ' sufx
-
-    german_mobile :: Text -> Text
-    --german_mobile = split_area "+49" '1' 2
-    german_mobile wpx =
-      let (area,endnr) = Text.splitAt 2 $ Text.filter Char.isDigit wpx
-      in "+49 1" <> area <> Text.cons ' ' endnr
-
-    repl_nondigit :: Char -> Char
-    repl_nondigit c
-      | Char.isDigit c = c
-      | c == '+'       = '+'
-      | otherwise      = ' '

backend/src/Utils/Pandoc.hs

@@ -1,51 +0,0 @@
--- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Utils.Pandoc where
-
-
-import Import.NoModel
-
-import Data.Either (fromRight)
--- import qualified Data.Char          as Char
--- import qualified Data.Text as Text
--- import qualified Data.CaseInsensitive as CI
-import Text.Blaze (toMarkup)
-import Text.Blaze.Html.Renderer.Text (renderHtml)
-import qualified Text.Pandoc as P
-
-
-markdownToHtml :: Html  -> Either P.PandocError Html
-markdownToHtml html  = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html)
-
-htmlToPlainText :: Html -> Either P.PandocError Text
-htmlToPlainText html = P.runPure $ P.writePlain htmlWriterOptions =<< P.readHtml     markdownReaderOptions (toStrict $ renderHtml html)
-
-plainTextToHtml :: Text -> Html
-plainTextToHtml text = fromRight (toMarkup text) $ P.runPure $
-  P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions text
-  -- Line below does not work as intended, also see Handler.Utils.Pandoc.plaintextToMarkdownWith which uses this code
-  -- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]]
-
-plainHtmlToHtml :: Text -> Html
-plainHtmlToHtml text = fromRight (toMarkup text) $ P.runPure $
-  P.writeHtml5 htmlWriterOptions =<< P.readHtml markdownReaderOptions text
-
-
-
-htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions
-htmlReaderOptions = markdownReaderOptions
-markdownReaderOptions = def
-  { P.readerExtensions = P.pandocExtensions
-      & P.enableExtension P.Ext_hard_line_breaks
-      & P.enableExtension P.Ext_autolink_bare_uris
-  , P.readerTabStop = 2
-  }
-
-markdownWriterOptions, htmlWriterOptions :: P.WriterOptions
-markdownWriterOptions = def
-  { P.writerExtensions = P.readerExtensions markdownReaderOptions
-  , P.writerTabStop = P.readerTabStop markdownReaderOptions
-  }
-htmlWriterOptions = markdownWriterOptions

backend/src/Utils/Postal.hs

@@ -1,32 +0,0 @@
--- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
--- TODO: why is this Handler.Utils.Profile instead of Utils.Profile? 
--- TODO: consider merging with Handler.Utils.Users?
-module Utils.Postal
-  ( validPostAddress, validPostAddressText  
-  ) where
-
-import Import.NoModel
-import Model.Types.Markup
-
-import Data.Char
-import qualified Data.Text.Lazy as LT
-
-
--- | Primitive postal address requires at least one alphabetic character, one digit and a line break
-validPostAddress :: Maybe StoredMarkup -> Bool
-validPostAddress (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr
-validPostAddress _ = False
-
-validPostAddressText :: Text -> Bool
-validPostAddressText = validPostAddressLazyText . LT.fromStrict
-
-validPostAddressLazyText :: LT.Text -> Bool
-validPostAddressLazyText addr
-  | Just _ <- LT.find isLetter addr
-  , Just _ <- LT.find isNumber addr
-  -- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
-    = 1 < length (LT.lines addr)    
-validPostAddressLazyText _ = False

backend/src/Utils/Print/RenewQualification.hs

@@ -1,182 +0,0 @@
--- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
-
-module Utils.Print.RenewQualification where
-
-import Import
-import Text.Hamlet
-
-import           Data.Char as Char
-import qualified Data.Text as Text
-import qualified Data.CaseInsensitive as CI
-
-import Data.FileEmbed (embedFile)
-
-import Utils.Print.Letters
-import Handler.Utils.Widgets (nameHtml) -- , nameHtml')
-import Handler.Utils.Qualification (computeNewValidDate)
-
-
-defaultNotice :: Lang -> Bool -> Maybe Int -> Text -> Text -> Text -> [Text]
-defaultNotice l renewAuto elimit qualName qualShort newExpire =
-    [intro <> renewal <> bequick <> outro, still_needed, switch_lang] -- list of separate paragraphs
-  where
-    intro :: Text
-      | isDe l    = [st|Ein Zertifikat für Ihre Unterlagen kann nur direkt nach dem erfolgreichen Test erstellt werden.
-                        Das Zertifikat wird auf die Benutzerkennung ausgestellt. Zusammen mit diesem Schreiben können Sie Ihrem Arbeitgeber zeigen, dass Sie bestanden haben. |]
-      | otherwise = [st|A certificate for your records can only be generated immediately after a successful test.
-                        The certificate will be issued for the user login. The certificate and this letter may then prove that you have passed. |]
-    renewal :: Text
-      | not renewAuto = mempty
-      | isDe l        = [st|Bei erfolgreichem Abschluss der Schulung verlängert sich das Ablaufdatum automatisch auf den #{newExpire}. |]
-      | otherwise     = [st|Upon successful completion of the training, the expiry date will automatically be extended until #{newExpire}. |]
-    bequick :: Text
-      | isDe l      = "Wir empfehlen die Schulung zeitnah durchzuführen. "
-      | otherwise   = "We recommend completing the training as soon as possible. "
-    limit :: Text
-      | Just n <- elimit, n > 0, isDe l = [st|innerhalb von #{n} Versuchen |]
-      | Just n <- elimit, n > 0         = [st|within #{n} attempts |]
-      | otherwise                       = mempty
-    praxis :: Text
-      | renewAuto   = mempty
-      | isDe l      = "der Praxisteil und "
-      | otherwise   = "the practical part and "
-    outro :: Text
-      | isDe l      = [st|Sollte bis zum Ablaufdatum #{praxis}das E-Learning nicht #{limit}erfolgreich abgeschlossen sein, muss zur Wiedererlangung der Fahrberechtigung „#{qualShort}“ ein Grundkurs #{qualName} bei der Fraport Fahrerausbildung absolviert werden.|]
-      | otherwise   = [st|The licence irrevocably expires, if #{praxis}the e-learning is not successfully completed #{limit}by the expiry date. In this case, regaining licence "#{qualShort}" requires the completing of a normal training course #{qualName} again, as if no prior experience existed.|]
-    still_needed :: Text
-      | isDe l      = "Benötigen Sie die Fahrberechtigung nicht mehr, informieren Sie bitte die Fraport Fahrerausbildung."
-      | otherwise   = "Please inform us, if this driving licence is no longer required."
-    switch_lang :: Text
-      | isDe l      = "(Please contact us if you prefer letters in English.)"
-      | otherwise   = "(Kontaktieren Sie uns bitte, um zukünftige Briefe von uns in deutscher Sprache zu erhalten.)"
-
-
-isAnyDrivingLicence :: Text -> Maybe Text
--- isAnyDrivingLicence = firstJust (Text.stripSuffix "führerschein") . Text.words . Text.replace "-" " " . Text.replace "+" ""
-isAnyDrivingLicence = firstJust (Text.stripSuffix "führerschein") . Text.words . Text.map anyNonAlphaToBlank
-
-anyNonAlphaToBlank :: Char -> Char
-anyNonAlphaToBlank c
-  | Char.isAlpha c
-    = c
-  | otherwise = ' '
-
-qualificationText :: Lang -> Text -> Text -> (Text, Text, Text) -- (qarea, qformal, qlicence) i.e. (Rollfeld, Rollfeldfahrberechtigung, Rollfeldführerschein) translated
-qualificationText l _qName "GSS"
-  | isDe l
-    = ("Gabelstapler", "Fahrberechtigung Gabelstapler", "Gabelstaplerführerschein")
-  | otherwise
-    = ("forklift", "forklift driving licence", "forklift driving licence")
-qualificationText l qName@(isAnyDrivingLicence -> Just qPrefix) qShort
-  | isDe l
-    = (qPrefix, [st|Fahrberechtigung „#{qShort}“|], qName)
-  | qShort == "F"
-    = ("apron", [st|driving licence "#{qShort}"|], "apron driving licence")
-  | Text.isPrefixOf "R" qShort
-    = ("maneuvering area", [st|driving licence "#{qShort}"|], "maneuvering area driving licence")
-  | otherwise
-    = (qPrefix, qPrefix <> " driving licence", qName)
-qualificationText l qName qShort
-  | isDe l
-    = (qShort, [st|Fahrberechtigung „#{qShort}“|], qName)
-  | otherwise
-    = (qShort,  [st|driving licence "#{qShort}"|], qName)
-
-
-data LetterRenewQualification = LetterRenewQualification
-    { lmsLogin      :: LmsIdent
-    , lmsPin        :: Text
-    , qualHolderID  :: UserId
-    , qualHolderDN  :: UserDisplayName
-    , qualHolderSN  :: UserSurname
-    , qualExpiry    :: Day
-    , qualId        :: QualificationId
-    , qualName      :: Text
-    , qualShort     :: Text
-    , qualSchool    :: SchoolId
-    , qualDuration  :: Maybe Int
-    , qualRenewAuto :: Bool
-    , qualELimit    :: Maybe Int
-    , isReminder    :: Bool
-    }
-  deriving (Eq, Show)
-
-
--- this datatype is specific to this letter only, and just to avoid code duplication for derived data or constants
-data LetterRenewQualificationData = LetterRenewQualificationData { lmsUrl, lmsUrlLogin, lmsUrlPassword, lmsIdent :: Text }
-  deriving (Eq, Show)
-
-letterRenewalQualificationFData :: LetterRenewQualification -> LetterRenewQualificationData
-letterRenewalQualificationFData LetterRenewQualification{lmsLogin, lmsPin} = LetterRenewQualificationData{..}
-  where
-    lmsUrl          = "drive.fraport.de"
-    lmsUrlLogin     = "https://" <> lmsUrl <> "/?username=" <> lmsIdent
-    lmsUrlPassword  = lmsUrlLogin <> "&password=" <> lmsPin
-    lmsIdent        = getLmsIdent lmsLogin
-
-
-instance MDLetter LetterRenewQualification where
-  encryptPDFfor     _ = PasswordUnderling
-  getLetterKind     _ = PinLetter
-  getLetterEnvelope l = maybe 'q' (Char.toLower . fst) $ Text.uncons (qualShort l)
-  getTemplate       _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_renewal.md")
-  getMailSubject    l = SomeMessage $ MsgMailSubjectQualificationRenewal $ qualShort l
-  getMailBody l@LetterRenewQualification{..} = Just $ \DateTimeFormatter{ format } ->
-    let LetterRenewQualificationData{..} = letterRenewalQualificationFData l
-    in $(ihamletFile "templates/mail/body/qualificationRenewal.hamlet")
-
-  letterMeta l@LetterRenewQualification{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} =
-    let LetterRenewQualificationData{..} = letterRenewalQualificationFData l
-        isSupervised = rcvrId /= qualHolderID
-        newExpire = computeNewValidDate (fromMaybe 0 qualDuration) qualExpiry
-        (qArea, qFormal, qLicence) = qualificationText lang qualName qualShort
-    in mkMeta $
-      guardMonoid isSupervised
-      [ toMeta "supervisor" userDisplayName
-      ] <>
-      guardMonoid isReminder
-      [ toMeta "reminder"       ("reminder"::Text)
-      ] <>
-      guardMonoid (not qualRenewAuto)
-      [ toMeta "practical"      True          -- note: definied or undefined matters, bool value is unimportant
-      ] <>
-      [ toMeta "lang"           lang
-      , toMeta "login"          lmsIdent
-      , toMeta "pin"            lmsPin
-      , toMeta "examinee"       qualHolderDN
-      , toMeta "subject-meta"   qualHolderDN
-      , toMeta "expiry"         (format SelFormatDate qualExpiry)
-      , mbMeta "validduration"  (show <$> qualDuration)
-      , toMeta "url-text"       lmsUrl
-      , toMeta "url"            lmsUrlPassword -- ok for PDF, since it contains the PIN already
-      , toMeta "notice"       $ defaultNotice lang qualRenewAuto qualELimit qualName qualShort $ format SelFormatDate newExpire
-      , toMeta "de-subject"     [st|Verlängerung Fahrberechtigung „#{qualShort}“ (#{qualName})|]
-      , toMeta "en-subject"     [st|Renewal of driving licence "#{qualShort}" (#{qualName})|]
-      , toMeta "de-opening"   $ bool [st|Guten Tag #{qualHolderDN},|] [st|Guten Tag #{userDisplayName},|] isSupervised
-      , toMeta "en-opening"   $ bool [st|Dear #{qualHolderDN},|]      [st|Dear #{userDisplayName},|]      isSupervised
-      , toMeta "qarea"          qArea
-      , toMeta "qformal"        qFormal
-      , toMeta "qlicence"       qLicence
-      ] -- NOTE: use [st|some simple text with interpolation|]
-
-  getPJId LetterRenewQualification{..} =
-    PrintJobIdentification
-      { pjiName             = bool "Renewal" "Renewal Reminder" isReminder
-      , pjiApcAcknowledge   = "lms-" <> getLmsIdent lmsLogin
-      , pjiRecipient        = Nothing       -- to be filled later
-      , pjiSender           = Nothing
-      , pjiAffected         = Just qualHolderID
-      , pjiCourse           = Nothing
-      , pjiQualification    = Just qualId
-      , pjiLmsUser          = Just lmsLogin
-      , pjiFileName         = "renew_" <> CI.original (unSchoolKey qualSchool) <> "-" <> qualShort <> "_" <> qualHolderSN
-        -- let nameRecipient = abbrvName <$> recipient
-        --     nameSender    = abbrvName <$> sender
-        --     nameCourse    = CI.original . courseShorthand        <$> course
-        --     nameQuali     = CI.original . qualificationShorthand <$> quali
-        -- in .. = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
-      }

backend/src/Utils/Users.hs

@@ -1,113 +0,0 @@
--- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
-
-module Utils.Users
-  ( AuthenticationKind(..)
-  , AddUserData(..)
-  , addNewUser, addNewUserDB
-  ) where
-
-import Import
-
-data AuthenticationKind = AuthKindLDAP | AuthKindPWHash | AuthKindNoLogin
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Universe, Finite)
---instance Universe AuthenticationKind
---instance Finite AuthenticationKind
-embedRenderMessage ''UniWorX ''AuthenticationKind id
-nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2
-
-mkAuthMode :: AuthenticationKind -> AuthenticationMode
-mkAuthMode AuthKindLDAP     = AuthLDAP
-mkAuthMode AuthKindPWHash   = AuthPWHash ""
-mkAuthMode AuthKindNoLogin  = AuthNoLogin
-
-{-
-classifyAuth :: AuthenticationMode -> AuthenticationKind
-classifyAuth AuthLDAP     = AuthKindLDAP
-classifyAuth AuthPWHash{} = AuthKindPWHash
-classifyAuth AuthNoLogin  = AuthKindNoLogin
--} 
-
-data AddUserData = AddUserData
-  { audTitle            :: Maybe Text
-  , audFirstName        :: Text
-  , audSurname          :: UserSurname
-  , audDisplayName      :: UserDisplayName
-  , audDisplayEmail     :: UserEmail
-  , audMatriculation    :: Maybe UserMatriculation
-  , audSex              :: Maybe Sex
-  , audBirthday         :: Maybe Day
-  , audMobile           :: Maybe Text 
-  , audTelephone        :: Maybe Text   
-  , audFPersonalNumber  :: Maybe Text 
-  , audFDepartment      :: Maybe Text 
-  , audPostAddress      :: Maybe StoredMarkup
-  , audPrefersPostal    :: Bool
-  , audPinPassword      :: Maybe Text
-  , audEmail            :: UserEmail
-  , audIdent            :: UserIdent
-  , audAuth             :: AuthenticationKind
-  }
-
--- | Adds a new user to database, no background jobs are scheduled, no notifications send
--- Note: `Foundation.Yesod.Auth` contains similar code with potentially differing defaults!
-addNewUser :: AddUserData -> Handler (Maybe UserId)
-addNewUser aud = do
-  udc <- getsYesod $ view _appUserDefaults
-  usr <- makeUser udc aud
-  runDB $ insertUnique usr
-
--- | Variant of `addNewUser` which allows for rollback through follwing throws
-addNewUserDB :: AddUserData -> DB (Maybe UserId)
-addNewUserDB aud = do 
-  udc <- liftHandler $ getsYesod $ view _appUserDefaults
-  usr <- makeUser udc aud
-  insertUnique usr
-
-makeUser :: MonadIO m => UserDefaultConf -> AddUserData -> m User
-makeUser UserDefaultConf{..} AddUserData{..} = do
-  now <- liftIO getCurrentTime
-  return User
-    { userIdent                   = audIdent
-    , userMaxFavourites           = userDefaultMaxFavourites
-    , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
-    , userTheme                   = userDefaultTheme
-    , userDateTimeFormat          = userDefaultDateTimeFormat
-    , userDateFormat              = userDefaultDateFormat
-    , userTimeFormat              = userDefaultTimeFormat
-    , userDownloadFiles           = userDefaultDownloadFiles
-    , userWarningDays             = userDefaultWarningDays
-    , userShowSex                 = userDefaultShowSex
-    , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
-    , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
-    , userNotificationSettings    = def
-    , userLanguages               = Nothing
-    , userCsvOptions              = def { csvFormat = review csvPreset CsvPresetXlsx }
-    , userTokensIssuedAfter       = Nothing
-    , userCreated                 = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey          = audFPersonalNumber
-    , userLastAuthentication      = Nothing
-    , userEmail                   = audEmail
-    , userDisplayName             = audDisplayName
-    , userDisplayEmail            = audDisplayEmail
-    , userFirstName               = audFirstName
-    , userSurname                 = audSurname
-    , userTitle                   = audTitle
-    , userSex                     = audSex
-    , userBirthday                = audBirthday
-    , userMobile                  = audMobile
-    , userTelephone               = audTelephone
-    , userCompanyPersonalNumber   = audFPersonalNumber
-    , userCompanyDepartment       = audFDepartment    
-    , userPostAddress             = audPostAddress
-    , userPostLastUpdate          = Nothing
-    , userPrefersPostal           = audPrefersPostal
-    , userPinPassword             = audPinPassword
-    , userMatrikelnummer          = audMatriculation
-    , userAuthentication          = mkAuthMode audAuth
-    }
-  

backend/src/Yesod/Form/Types/Instances.hs

@@ -1,27 +0,0 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Yesod.Form.Types.Instances
-  () where
-
-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)

backend/templates/comm-center.hamlet

@@ -1,9 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <p> 
-    ^{ccTable}

backend/templates/exam-missing/de-de-formal.hamlet

@@ -1,11 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <p>
-    Keine momentan offene Prüfung gefunden für _{MsgTableCourse} #{csh}.
-  <p>
-    ^{mkExamCreateBtn}

backend/templates/exam-missing/en-eu.hamlet

@@ -1,11 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <p>
-    No currently open exam found for _{MsgTableCourse} #{csh}. 
-  <p>
-    ^{mkExamCreateBtn}

backend/templates/fraport_licence_expiry.md.license

@@ -1,3 +0,0 @@
-SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
-
-SPDX-License-Identifier: AGPL-3.0-or-later

backend/templates/i18n/avs-synchronisation/de-de-formal.hamlet

@@ -1,83 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <h2>
-    Personendaten aller AVS Fahrberechtigten
-
-  $if numUnknownLicenceOwners > 0 
-    <p> 
-      ^{modal (text2widget (tshow numUnknownLicenceOwners <> " Personen IDs")) (Right (text2widget ("AVS Personen IDs: " <> tshow unknownLicenceOwners)))} #
-      mit einer Fahrberechtigung wurden im AVS gefunden, welche FRADrive unbekannt sind. #
-
-      Es gibt zwei Möglichkeiten zum Auflösen dieses Problems: #
-    <p>
-      ^{btnImportUnknownWgt}^{revokeUnknownSafetyWgt}
-
-  $else 
-    <p>
-      Die Personendaten aller Fahrberechtigten im AVS sind auch in FRADrive bekannt.  
-
-<section>
-  <h2>
-    Abweichende Fahrberechtigungen
-  <p>
-    Die folgenden Abschnitte zeigen alle Abweichungen
-    zwischen dem AVS und den in FRADrive vorliegenden Fahrberechtigungen. #
-    Es wird dringend empfohlen, die Fahrberechtigungen im AVS anzupassen 
-    und nicht umgekehrt.
-    
-  <h3>
-    Fahrberechtigung Rollfeld gültig in FRADrive, fehlt aber im AVS
-  <p>
-    ^{tb2}
-  <h3>
-    Fahrbrechtigung Rollfeld ungültig in FRADrive, aber im AVS vorhanden und Fahrberechtigung Vorfeld gültig in FRADrive
-  <p>
-    ^{tb1down}
-  <h3>
-    Fahrberechtigung Vorfeld gültig in FRADrive, fehlt aber im AVS
-  <p>
-    ^{tb1up}
-  <h3>
-    Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden (Roll- oder Vorfeld)
-  <p>
-    ^{tb0}
-    
-$if notNull avsLicenceSynchTimes
-  <section>
-    <h2>
-      Automatische AVS Fahrlizenzen Sychronisation
-    <p>
-      <dl .deflist>
-        <dt .deflist__dt>
-          Uhrzeiten Synchronisation
-        <dd .deflist__dd>
-          Werktags, wenige Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes}
-        <dt .deflist__dt>
-          Synchronisationslevel
-        <dd .deflist__dd>
-          <strong>#{avsLicenceSynchLevel}: #
-          $case avsLicenceSynchLevel
-            $of 1
-              Nur Vorfeld-Fahrberechtigungen entziehen
-            $of 2 
-              Vorfeld-Fahrberechtigungen entziehen und gewähren
-            $of 3
-              Vorfeld-Fahrberechtigungen entziehen und gewähren, #
-              so wie Rollfeld-Fahrberechtigungen zu Vorfeld-Fahrberechtigungen herabstufen
-            $of _
-              Vorfeld- und Rollfeld-Fahrberechtigungen entziehen und gewähren
-        $maybe reasons <- avsLicenceSynchReasonFilter
-          <dt .deflist__dt>
-            Ausnahmen
-          <dd .deflist__dd>
-            Keine automatische Synchronisation, wenn die Begründung des letzten Un-/Blocks zu diesen regulären Ausdruck passt: #{reasons}
-        $maybe maxChange <- avsLicenceSynchMaxChanges
-          <dt .deflist__dt>
-            Maximal Änderungen
-          <dd .deflist__dd>
-            Keine Synchronisation eines Levels durchführen, welches mehr als #{maxChange} Änderungen hätte

backend/templates/i18n/avs-synchronisation/en-eu.hamlet

@@ -1,82 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <h2>
-    Person data of all AVS drivers
-
-  $if numUnknownLicenceOwners > 0
-    <p>
-      ^{modal (text2widget (tshow numUnknownLicenceOwners <> " Person IDs")) (Right (text2widget ("AVS Person IDs: " <> tshow unknownLicenceOwners)))} #      
-      owning a driving licence within AVS were found, which are unknown within the FRADrive database. #
-
-      There are two solutions to this problem: #
-    <p>
-      ^{btnImportUnknownWgt}
-      ^{revokeUnknownSafetyWgt}
-
-  $else
-    <p>
-      All AVS driving licence owners are also registered with FRADrive as expected.
-
-<section>
-  <h2>
-    Nonconforming driving licence
-  <p>
-    The following sections show all discrepancies
-    between AVS and FRADrive with respect to driving licences. #
-    It is recommended to adjust AVS driving licences and keep FRADrive as it is.
-
-  <h3>
-    Maneuvering area driving licence 'R' valid in FRADrive, but not in AVS
-  <p>
-    ^{tb2}
-  <h3>
-    Maneuvering area driving licence 'R' invalid in FRADrive, but valid in AVS and having a valid 'F' in FRADrive
-  <p>
-    ^{tb1down}
-  <h3>
-    Apron driving licence 'F' valid in FRADrive, but not in AVS
-  <p>
-    ^{tb1up}
-  <h3>
-    No valid driving licence in FRADrive, but having any driving licence in AVS (maneuvering or apron)
-  <p>
-    ^{tb0}
-
-$if notNull avsLicenceSynchTimes
-  <section>
-    <h2>
-      Automatic AVS licence sychronisation
-    <p>
-      <dl .deflist>
-        <dt .deflist__dt>
-          Synchronisation times
-        <dd .deflist__dd>
-          Synchronize on weekdays, few minutes after each full hour: #{tshow avsLicenceSynchTimes}
-        <dt .deflist__dt>
-          Synchronisation level
-        <dd .deflist__dd>
-          <strong>#{avsLicenceSynchLevel}: #
-          $case avsLicenceSynchLevel
-            $of 1
-              Revoke apron driving licences only
-            $of 2 
-              Grant and revoke apron driving licences only
-            $of 3
-              Grant and revoke apron driving licences and downgrade maneuvering area licences to apron driving licences
-            $of _
-              Grant and revoke all driving licences automatically
-        $maybe reasons <- avsLicenceSynchReasonFilter
-          <dt .deflist__dt>
-            Exemptions
-          <dd .deflist__dd>
-            Do not synchronize changes where the last un-/block reason matches #{reasons}
-        $maybe maxChange <- avsLicenceSynchMaxChanges
-          <dt .deflist__dt>
-            Max changes
-          <dd .deflist__dd>
-            Do not synchronize a licence level if the number of changes exceeds #{maxChange}

backend/templates/i18n/config-interfaces/de-de-formal.hamlet

@@ -1,42 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <h2>
-    _{MsgConfigInterfacesHeading}
-  <div>
-    <p>
-      Eine Schnittstelle gilt als fehlgeschlagen, wenn die letzte Transaktion dieser Schnittstelle ein konkreten Fehler lieferte, #
-      oder wenn seit einer gewissen Zugriffsfrist kein erneuter Erfolg für diese Schnittstelle registriert wurde. #
-    <p>
-      Diese Zeitspanne beträgt normalerweise: #{defWarnTime} #
-    <p>
-      Mit der nachfolgend gezeigten Tabelle kann diese Zugriffsfrist zwischen letztem Erfolg und dem Anzeigen eines Fehlers aufgrund #
-      des Ausbleibens eines erneuten Erfolges für einzelne Schnittstellen geändert werden. #
-      Einträge mit unspezifiertem _{MsgInterfaceSubtype} und/oder _{MsgInterfaceWrite} betreffen alle drauf passenden Schnittstellen, #
-      sofern es keine anderen passenden, besser spezifizierten Einträge gibt. #
-    <p>
-      Die Zeitspanne ist hier immer in Stunden anzugeben. #
-      Eine negative Stundenzahl deaktiviert den Warnungsmechanismus für ausbleibende wiederholte Erfolge; #
-      in diesem Fall werden für die Schnittstelle nur tatsächliche Fehlschläge als Fehler gemeldet. #
-      Eine negative Zeitspanne von -100 oder weniger deaktiviert alle Warnungen für diese Schnittstelle.
-    <p>
-      ^{configTable}
-
-<section>
-  <h2>
-    _{MsgMenuInterfaces}  
-  <div>
-    <p>
-      Current interface health is shown here for reference
-    <p> 
-      $if interfacesBadNr > 0
-        _{MsgInterfacesFail interfacesBadNr}
-      $else
-        _{MsgInterfacesOk}
-    ^{interfaceTable}
-
-

backend/templates/i18n/config-interfaces/en-eu.hamlet

@@ -1,38 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <h2>
-    _{MsgConfigInterfacesHeading}
-  <div>
-    <p>
-      An interface is flagged as failed, if an error is reported or if no new success had been reported within 
-      its maximum usage period, usually #{defWarnTime} #
-    <p>
-      The following table allows to change the time span between the last success and before an error is raised. #
-      A time value having _{MsgInterfaceSubtype} and/or _{MsgInterfaceWrite} left unspecified affects all matching interfeaces, #
-      unless another more specified matching row exists for a particular interface. #
-    <p>
-      The time span is configure by a number of hours. #
-      A negative hour value disables the raising of an error by time entirely; in this case, an error is only raised if the last interface transaction reported failure. #
-      A negative value of less than -100 disables all warnings for this interface.
-    <p>
-      ^{configTable}
-
-<section>
-  <h2>
-    _{MsgMenuInterfaces}  
-  <div>
-    <p>
-      Current interface health is shown here for reference
-    <p> 
-      $if interfacesBadNr > 0
-        _{MsgInterfacesFail interfacesBadNr}
-      $else
-        _{MsgInterfacesOk}
-    ^{interfaceTable}
-
-

backend/templates/i18n/day-view/de-de-formal.hamlet

@@ -1,32 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-$maybe tbl <- tableDaily
-  <section>
-    <p>
-      ^{tbl}
-    <p>
-      ^{consistencyBtn}
-  <section .profile>
-    <h3>Hinweise zu den Formularspalten
-    <dl .deflist.profile-dl>
-      <dt .deflist__dt>
-        _{MsgTutorialDrivingPermit}, _{MsgTutorialEyeExam}, _{MsgTutorialNote}
-      <dd .deflist__dd>
-        Pro Kurs und Teilnehmer wird je ein Wert gespeichert.
-      <dt .deflist__dt>
-        _{MsgTutorialDayAttendance mempty}, _{MsgTutorialDayNote mempty}
-      <dd .deflist__dd>
-        Pro Tag, Kurs und Teilnehmer wird je ein Wert gespeichert.
-      <dt .deflist__dt>
-        _{MsgTableUserParkingToken mempty}
-      <dd .deflist__dd>
-        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
-  <section>
-    An diesem Tag sind zur Zeit keine Kurse eingetragen.
-

backend/templates/i18n/day-view/en-eu.hamlet

@@ -1,32 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-$maybe tbl <- tableDaily      
-  <section>
-    <p> 
-      ^{tbl}
-    <p>
-      ^{consistencyBtn}      
-  <section .profile>
-    <h3>Note how form data is saved
-    <dl .deflist.profile-dl>
-      <dt .deflist__dt>
-        _{MsgTutorialDrivingPermit}, _{MsgTutorialEyeExam}, _{MsgTutorialNote}
-      <dd .deflist__dd>
-        For each course and participant pairing, one value is stored each.
-      <dt .deflist__dt>
-        _{MsgTutorialDayAttendance mempty}, _{MsgTutorialDayNote mempty}
-      <dd .deflist__dd>
-        For each day, course and participant, one value is stored each.
-      <dt .deflist__dt>
-        _{MsgTableUserParkingToken mempty}
-      <dd .deflist__dd>
-        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
-  <section>
-    No courses are currently scheduled on this day.
-

backend/templates/i18n/firm-supervisors/de-de-formal.hamlet

@@ -1,26 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <p>
-    Bitte beachten: Ansprechpartner-Beziehung bestehen unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen! #
-  
-  <p>
-    Daraus folgt zum Beispiel, dass wenn <em>x</em> ein Standard-Ansprechpartner für Firma <em>a</em> ist #
-    und wenn <em>y</em> sowohl Firma <em>a</em> als auch <em>b</em> angehört, #
-    dass <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird. #
-    Dies kann hier mit der Aktion "Firmenansprechpartner entfernen" nicht geändert werden, #
-    da die Ansprechpartnerbeziehung ja über eine andere Firma weiter existiert.
-
-^{firmContactInfo}  
-
-^{formFirmAction}
-
-<section>
-  <h2>
-    _{MsgTableSupervisor}
-  <div>
-    ^{fsprTable}

backend/templates/i18n/firm-supervisors/en-eu.hamlet

@@ -1,24 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <p>
-    Note that supervisionship is company independent! #
-  <p>
-    For example, if <em>x</em> is a regular supervisor for company <em>a</em> and <em>y</em> belongs to companies <em>a</em> and <em>b</em>, #
-    then <em>x</em> will be listed as a foreign supervisor for company <em>b</em>. #
-    This cannot be changed through action "Remove default supervisor" here, since the external supervisionship persists.
-
-^{firmContactInfo}
-
-^{formFirmAction}
-
-<section>
-  <h2>
-    _{MsgTableSupervisor}
-  <div>
-    ^{fsprTable}
-

backend/templates/i18n/lms-orphans/de-de-formal.hamlet

@@ -1,33 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2025 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <p> 
-    Gezeigt werden E‑Learning Logins, welche für Qualifikation #{qsh} an FRADrive zurückgemeldet wurden #
-    und von FRADrive nicht mehr zugeordnet werden können. #
-    
-    Normalerweise löscht das LMS beendete E‑Learning Logins selbstständig. #
-    In manchen Fällen passiert dies aus unbekanntem Grund jedoch nicht. #
-    Wenn jedoch ein Grund bekannt sein sollte, wie zum Beispiel ein manueller Neustart des E‑Learnings, #
-    wird dieser in Spalte "_{MsgLmsOrphanReason}" angezeigt. #
-    
-  <p>
-    Verwaiste Logins werden beim nächsten Abruf der E‑Learning Logins von FRADrive zur Löschung durch das LMS gemeldet. #
-    Die Auswahl, ob ein E‑Learning Login zur Löschung gemeldet wird, hängt von folgenden Kriterien ab: #
-    <ul>
-      <li>"_{MsgLmsOrphanSeenFirst}" liegt mindestens #{lmsOrphanDeletionDays} Tage zurück.
-      <li>"_{MsgLmsOrphanSeenLast}" liegt höchstens #{lmsOrphanRepeatHours} Stunden zurück.
-      <li>"_{MsgLmsOrphanDeletedLast}", d.h. der letzte Löschantrag für diesen Login ist älter als #{lmsOrphanRepeatHours} Stunden #
-          oder wurde noch gar nicht gestellt.
-      <li>Der E‑Learning Login ist auch unter keiner anderen Qualifikation in FRADrive bekannt.
-  <p>
-    Es werden jedoch pro Abruf nur #{lmsOrphanDeletionBatch} E‑Learning Logins zur Löschung an das LMS gemeldet. #
-    Dabei werden Logins bevorzugt welche noch gar nicht oder vor der längsten Zeit gemeldet wurden ("_{MsgLmsOrphanDeletedLast}"), #
-    sollte davon es jeweils mehrere Kandidaten geben, dann werden diejenigen ausgewählt, welche kürzlich zurückgemeldet wurden ("_{MsgLmsOrphanSeenLast}").
-
-<section>
-  <p>
-    ^{orvTable}

backend/templates/i18n/lms-orphans/en-eu.hamlet

@@ -1,33 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2025 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <p> 
-    Displayed are e‑learning logins that have been reported back to FRADrive for qualification #{qsh}, #
-    but which are unknown to FRADrive. #
-    
-    Normally, the LMS automatically deletes completed e‑learning logins. #
-    In some cases, however, this does not happen for unknown reasons. #
-    If a reason is known, such as a manual restart of the e‑learning, #
-    this is shown in the column "_{MsgLmsOrphanReason}". #
-    
-  <p>
-    Orphaned logins will be reported for deletion by FRADrive to the LMS during the next retrieval of e‑learning logins. #
-    The decision whether an e‑learning login is reported for deletion depends on the following criteria: #
-    <ul>
-      <li>"_{MsgLmsOrphanSeenFirst}" is at least #{lmsOrphanDeletionDays} days ago.
-      <li>"_{MsgLmsOrphanSeenLast}" is at most #{lmsOrphanRepeatHours} hours ago.
-      <li>"_{MsgLmsOrphanDeletedLast}", i.e., the last deletion request for this login is older than #{lmsOrphanRepeatHours} hours #
-          or has not been made yet.
-      <li>The e‑learning login is not associated with any other qualification within FRADrive.
-  <p>
-    However, only #{lmsOrphanDeletionBatch} e‑learning logins are reported for deletion to the LMS per request. #
-    Logins that have not yet been reported for deletion at all or were reported the longest time ago ("_{MsgLmsOrphanDeletedLast}") are preferred, #
-    if there are multiple candidates, those that were most recently reported back ("_{MsgLmsOrphanSeenLast}") will be selected.
-
-<section>
-  <p>
-    ^{orvTable}

backend/templates/i18n/user-receivers/de-de-formal.hamlet

@@ -1,46 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2025 Steffen Jost <jost@tcs.ifi.lmu.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-
-<section>
-<p>
-    Benachrichtigungen für ^{usrWgt} ^{widgetMailPrefPin usr} #
-    $if usrReceives
-        gehen #
-        $maybe _ <- mrtbl
-            ebenfalls an die unten aufgeführten Personen:
-        $nothing
-            nur an diese Person selbst.
-    $else
-        $maybe _ <- mrtbl
-            gehen tatsächlich nur an die unten aufgeführten Personen:
-        $nothing
-            werden momentan an niemanden zugestellt!
-$maybe (tbl, mbUsrCmps) <- mrtbl
-    <p>
-        ^{tbl}
-    <p>        
-        $maybe usrCmps <- mbUsrCmps
-            <h4>
-                _{MsgCompany} ^{usrWgt}:
-            <ul .list--inline .list--comma-separated>
-                ^{usrCmps}
-        $nothing
-            Für ^{usrWgt} ist momentan keine Firmenzugehörigkeit bekannt.
-    <p>
-        <h4>
-            Hinweis:
-        Mit welchem Passwort PDF Anhänge geschützt werden, hängt vom Nachrichtentyp ab. #
-
-        Zum Beispiel werden Pin Briefe für ablaufende Qualifikationen #
-        $if hasPwd
-            mit dem Passwort von ^{usrWgt} geschützt. #
-        $else
-            nicht geschützt, da kein Pin Passwort gesetzt ist. #
-
-        Für andere Benachrichtigungen wird meist das Passwort des tatsächlichen Empfängers gewählt, sofern eins gesetzt wurde.
-
-        Die Voreinstellung für das PDF Passwort ist die Hauptausweisnummer, inklusive Punkt.

backend/templates/i18n/user-receivers/en-eu.hamlet

@@ -1,44 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2025 Steffen Jost <jost@tcs.ifi.lmu.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-
-<section>
-<p> 
-    Notifications for ^{usrWgt} ^{widgetMailPrefPin usr} # 
-    $if usrReceives         
-        $maybe _ <- mrtbl 
-            are also sent additionally to the following persons: 
-        $nothing 
-            are received only by them. 
-    $else 
-        $maybe _ <- mrtbl
-            are only sent to the following persons instead: 
-        $nothing
-            are currently not delivered to anyone! 
-$maybe (tbl, mbUsrCmps) <- mrtbl
-    <p>
-        ^{tbl}
-    <p>        
-        $maybe usrCmps <- mbUsrCmps
-            <h4>
-                _{MsgCompany} ^{usrWgt}:
-            <ul .list--inline .list--comma-separated>
-                ^{usrCmps}
-        $nothing
-            ^{usrWgt} is currently not affiliated with any company.
-    <p> 
-        <h4>
-            Note:
-        The password used to protect PDF attachments depends on the message type. #
-        For example, pin letters for expiring qualifications #
-        $if hasPwd
-            are protected by the password of ^{usrWgt}. #
-        $else
-            are not protected, since ^{usrWgt} has no Pin password set. #
-
-        For other notifications, the password of the actual recipient is usually chosen, if a password has been set.
-
-        The default PDF password is their main ID card number, including the period.

backend/templates/letter/din5008with_pin.latex.license

@@ -1,3 +0,0 @@
-SPDX-FileCopyrightText: 2023-24 Steffen Jost <S.Jost@Fraport.de>
-
-SPDX-License-Identifier: LicenseRef-Fraport-Corporate-Design

backend/templates/letter/fraport_renewal.md

@@ -1,159 +0,0 @@
----
-### Metadaten, welche hier eingestellt werden:
-# Absender
-author: Fraport AG - Fahrerausbildung (AVN-AR)
-phone: +49 69 690-30306
-email: fahrerausbildung@fraport.de
-place: Frankfurt am Main
-return-address: 
- - 60547 Frankfurt
-de-opening: Guten Tag,
-en-opening: Dear driver,
-de-closing: |
-  Mit freundlichen Grüßen  
-  \vspace{2EX}
-  Fraport Fahrerausbildung
-en-closing: |
-  With kind regards  
-  \vspace{2EX}
-  Fraport Driver Training
-encludes:
-hyperrefoptions: colorlinks=false
-
-### Metadaten, welche automatisch ersetzt werden:
-de-subject: 'Verlängerung Fahrberechtigung "F" (Vorfeldführerschein)'
-en-subject: Renewal of apron driving license
-qarea: 'Vorfeld'
-qformal: 'Fahrberechtigung'
-qlicence: 'Führerschein'
-url-text: 'drive.fraport.de'
-url: 'https://drive.fraport.de'
-date: 11.11.1111
-expiry: 00.00.0000
-lang: de-DE
-is-de: true
-login: 123456
-pin: abcdef
-paper: pin
-# Emfpänger
-examinee: P. Rüfling
-address:
- - E. M. Pfänger
- - Musterfirma GmbH
- - Musterstraße 11
- - 12345 Musterstadt
-...
-$if(titleblock)$
-$titleblock$
-
-$endif$
-$for(header-includes)$
-$header-includes$
-        
-$endfor$
-$for(include-before)$
-$include-before$
-
-$endfor$
-
-$if(is-de)$
-
-<!-- deutsche Version des Briefes  -->
-
-$if(reminder)$
- dies ist die **letzte Erinnerung**: Bis $date$ wurde das E-Learning noch nicht abgeschlossen. Um
-$else$
- um
-$endif$
-$if(supervisor)$
- die $qformal$ von **$examinee$**
-$else$
- Ihre $qformal$
-$endif$
-zu verlängern, benötigen wir bis zum **$expiry$** den Nachweis, 
-dass die 
-$if(practical)$
- theoretische und praktische 
-$endif$
-flughafenspezifische $qarea$ Recurrent Schulung 
-der Fraport AG gemäß Verordnung der Europäische Union Nr. 139/2014 absolviert wurde. 
-
-Die Online-Schulung der Fraport AG ist erreichbar unter folgendem Link:
-[$url-text$]($url$)
-
-Benutzername und Passwort für die Fraport Online-Schulung finden Sie untenstehend. 
-Die Weitergabe der persönlichen Benutzerdaten an Dritte ist untersagt. 
-$if(supervisor)$
-Ausschließlich Sie sind berechtigt, die Benutzerdaten an den Schulungsteilnehmer auszuhändigen. 
-$endif$
-
-Für die Absolvierung der Schulungsmaßnahme werden ca. 2 Stunden benötigt.
-Der Abschluss der Schulung wird automatisch an das System der Fraport Fahrerausbildung übermittelt.
-
-$if(practical)$
- Nach erfolgreichem Abschluss der Online-Schulung
- $if(supervisor)$
- muss \textbf{$examinee$}
- $else$
- lassen Sie
- $endif$
- sich von Ihrer Firma zum praktischen Teil der Schulung
- $if(supervisor)$
- anmelden lassen.
- $else$
- anmelden.
- $endif$
- Im Rahmen der ca. 4-stündigen praktischen Auffrischung erfolgen Funkübungen 
- sowie die Durchführung einer Übungsfahrt mit Prüfungscharakter 
- im Start-/Landebahnsystem.
-$endif$
-
-
-$else$
-
-
-<!-- englische Version des Briefes  -->
-$if(reminder)$
- this is a last **reminder**: as of $date$, the e-learning has not been completed. In
-$else$
- in
-$endif$
-order to maintain
-$if(supervisor)$
- the $qformal$ of **$examinee$**,
-$else$
- your $qformal$,
-$endif$
-we require by **$expiry$**, that the 
-$if(practical)$
- theorectical and practical
-$endif$
-airport-specific $qarea$ recurrent training at Fraport AG,
-according to European Union Regulation No. 139/2014,
-has been completed.
-
-The e-learning can be accessed with this link:
-[$url-text$]($url$)
-
-The required username and password for this Fraport e-learning are provided below.
-Note that sharing of this personal login data with third parties is prohibited.
-$if(supervisor)$
-Only you are authorized to hand over the personal login data to the training participant.
-$endif$
-
-The completion of the e-learning will require abut ca. 2 hours.
-Results will be automatically transmitted to Fraport Driver Training.
-
-$if(practical)$
- After successful completion of the online training,
- $if(supervisor)$  
- $examinee$ must be scheduled by your company
- $else$
- your company must schedule you
- $endif$
- for the practical part of the training. 
- The ca. 4 hour practical refresher includes radio exercises and 
- an examination-style test drive within the runway system.
-$endif$  
-
-$endif$

backend/templates/mail-center.hamlet

@@ -1,9 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <p> 
-    ^{mcTable}

backend/templates/table/cell/listInline.hamlet

@@ -1,10 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<ul .list--iconless .list--inline .list--comma-separated>
-  $forall (attrs, widget) <- cells
-    <li *{attrs}>
-      ^{widget}

backend/templates/tutorial-participants.hamlet

@@ -1,29 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2022-25 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <dl .deflist>
-    <dt .deflist__dt>_{MsgTableTutorialOccurrence}
-    <dd .deflist__dd>
-      ^{occurrencesWidget tutorialRoomHidden tutorialTime}
-    <dt .deflist__dt>_{MsgTableTutorialTutors}
-    <dd .deflist__dd>
-      <ul>
-        $forall (Entity _ usr) <- tutors
-          <li>
-            ^{userEmailWidget usr}
-<section>
-  ^{participantTable}
-<section>
-$#  <h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
-  <h2>
-    _{MsgExamFormOccurrences}
-  <div>
-    <p>
-      $if hasExams
-        ^{gtaForm}
-      $else 
-        ^{mkExamCreateBtn}

backend/templates/widgets/lesson/set.hamlet

@@ -1,11 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-$if not (null lessons)
-  <ul .list--iconless>
-    $forall lsn <- lessons
-      <li>
-        ^{lsn}

backend/templates/widgets/lesson/single.hamlet

@@ -1,9 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 20 24 Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-#{lStart}–#{lEnd}
-$if not roomHidden
-  \ ^{foldMap roomReferenceWidget lessonRoom}

backend/templates/widgets/massinput/courseQualifications/add.hamlet

@@ -1,9 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-^{formView}
-<td .table__td>
-  ^{fvWidget submitView}

backend/templates/widgets/massinput/courseQualifications/form.hamlet

@@ -1,11 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<td .table__td>
-  #{csrf}
-  ^{fvWidget cquView}
-<td .table__td>
-  ^{fvWidget ordView}

backend/templates/widgets/massinput/courseQualifications/layout.hamlet

@@ -1,21 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<table .table .table--striped .table--hover>
-  <thead>
-    <tr .table__row .table__row--head>
-      <th .table__th>_{MsgTableQualification}
-      <th .table__th>_{MsgSortPriority}
-      <td>
-  <tbody>
-    $forall coord <- review liveCoords lLength
-      <tr .massinput__cell .table__row>
-        ^{cellWdgts ! coord}
-        <td>
-          ^{fvWidget (delButtons ! coord)}
-  <tfoot>
-    <tr .massinput__cell.massinput__cell--add>
-      ^{addWdgts ! (0, 0)}

backend/templates/widgets/occurrence/cell/weekly.hamlet

@@ -1,11 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <s.jost@fraport.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-_{ShortWeekDay scheduleDayOfWeek} #{scheduleStart'}–#{scheduleEnd'} 
-$if roomHidden
-  _{MsgTableTutorialRoomIsHidden}
-$else 
-  ^{foldMap roomReferenceWidget scheduleRoom}

cbt.sh

@@ -0,0 +1,7 @@
+#!/usr/bin/env bash
+
+# SPDX-FileCopyrightText: 2022 Sarah Vaupel <vaupel.sarah@campus.lmu.de>
+#
+# SPDX-License-Identifier: AGPL-3.0-or-later
+
+cbt_tunnels --username $CBT_USERNAME --authkey $CBT_AUTHKEY

compose.yaml

@@ -1,86 +1,35 @@
 services:
-  help:
-    image: docker.io/library/perl:stable
-    pull_policy: if_not_present
-    volumes:
-      - ./utils/makehelp.pl:/mnt/utils/makehelp.pl:ro
-      - ./Makefile:/tmp/Makefile:ro
-    command: /mnt/utils/makehelp.pl /tmp/Makefile
-
   frontend:
+    # image: registry.uniworx.de/fradrive/fradrive/frontend # TODO: reference to current branch required; how to do that here?
+    # pull_policy: if_not_present
     build:
-      context: ./frontend
+      dockerfile: ./docker/frontend/Dockerfile
-      dockerfile: ./Dockerfile
+      context: .
     environment:
       - PROJECT_DIR=/fradrive
     volumes:
-      - type: bind
+      - &fradrive-mnt .:/tmp/fradrive
-        source: ./frontend
-        target: /fradrive
-      - ./assets:/fradrive/assets:rw
-      - ./static:/fradrive/static:rw
-      - ./well-known:/fradrive/well-known:rw
-
   backend:
     # image: registry.uniworx.de/fradrive/fradrive/backend
     # pull_policy: if_not_present
     build:
-      context: ./backend
+      dockerfile: ./docker/backend/Dockerfile
-      dockerfile: ./Dockerfile
+      context: ./
-    environment:
-      PATH: /fradrive/bin:$PATH
     volumes:
-      - ./backend:/fradrive
+      - *fradrive-mnt
-      - ./bin:/fradrive/bin
-      - ./assets:/fradrive/assets:ro
-      - ./static:/fradrive/static:ro
-      - ./well-known:/fradrive/well-known:ro
     depends_on:
       - frontend
-      - postgres
-      - memcached
-      - minio
-      - maildev
-    ports:
-      - "3000:3000" # dev http
-      - "3443:3443" # dev https
-      - "8081:8081" # hoogle
-    # links:
-    #   - postgres
-    #   - memcached
-    #   - minio
-    #   - maildev
     stdin_open: true
-    network_mode: host
+  database:
-
+    # image: registry.uniworx.de/fradrive/fradrive/database
-  postgres:
+    # pull_policy: if_not_present
-    image: docker.io/library/postgres:12
+    build: ./docker/database
-    pull_policy: if_not_present
     ports:
-      - "5432:5432"
+      - "9876:5432"
-    environment:
+    # privileged: true
-      - POSTGRES_HOST_AUTH_METHOD=trust
-    volumes:
-      - ./docker/postgres/pg_hba.conf:/tmp/pg_hba.conf:ro
-      - ./docker/postgres/postgresql.conf:/tmp/postgresql.conf:ro
-      - ./docker/postgres/pgconfig.sh:/docker-entrypoint-initdb.d/_pgconfig.sh:ro
-      - ./docker/postgres/schema.sql:/docker-entrypoint-initdb.d/schema.sql:ro
 
-  memcached:
+#     driver: local
-    image: docker.io/library/memcached:latest
+#     driver_opts:
-    pull_policy: if_not_present
+#       type: none
-    ports:
+#       o: bind
-      - "11211:11211"
+#       device: ./
-
-  minio:
-    image: docker.io/minio/minio:latest
-    pull_policy: if_not_present
-    command: server `mktemp`
-    ports:
-      - "9000:9000"
-
-  maildev:
-    image: docker.io/maildev/maildev:latest
-    pull_policy: if_not_present
-    ports:
-      - "1025-1026:1025"

config/settings.yml

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -83,7 +83,6 @@ health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER
 
 synchronise-ldap-users-within: "_env:SYNCHRONISE_LDAP_WITHIN:1209600"   # 14 Tage in Sekunden
 synchronise-ldap-users-interval: "_env:SYNCHRONISE_LDAP_INTERVAL:3600"  # jede Stunde
-synchronise-ldap-users-expire: "_env:SYNCHRONISE_LDAP_EXPIRE:15897600"  # halbes Jahr in Sekunden
 
 synchronise-avs-users-within: "_env:SYNCHRONISE_AVS_WITHIN:5702400"     # alle 66 Tage
 synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600"   # alle 6 Stunden
@@ -91,6 +90,10 @@ 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: 15
+# job-lms-qualifications-dequeue-hour: 3
+
 log-settings:
   detailed:      "_env:DETAILED_LOGGING:false"
   all:           "_env:LOG_ALL:false"
@@ -146,22 +149,18 @@ ldap:
 ldap-re-test-failover: 60
 
 lms-direct:
-  upload-header:                "_env:LMSUPLOADHEADER:true"
+  upload-header:        "_env:LMSUPLOADHEADER:true"
-  upload-delimiter:             "_env:LMSUPLOADDELIMITER:"
+  upload-delimiter:     "_env:LMSUPLOADDELIMITER:"
-  download-header:              "_env:LMSDOWNLOADHEADER:true"
+  download-header:      "_env:LMSDOWNLOADHEADER:true"
-  download-delimiter:           "_env:LMSDOWNLOADDELIMITER:,"
+  download-delimiter:   "_env:LMSDOWNLOADDELIMITER:,"
-  download-cr-lf:               "_env:LMSDOWNLOADCRLF:true"
+  download-cr-lf:       "_env:LMSDOWNLOADCRLF:true"
-  orphan-deletion-days:         "_env:LMSORPHANDELETIONDAYS:33"
+  deletion-days:        "_env:LMSDELETIONDAYS:7"
-  orphan-deletion-batch:        "_env:LMSORPHANDELETIONBATCH:12"
-  orphan-deletion-repeat-hours: "_env:LMSORPHANDELETIONREPEATHOURS:24"
 
 avs:
-  host:         "_env:AVSHOST:skytest.fra.fraport.de"
+  host:    "_env:AVSHOST:skytest.fra.fraport.de"
-  port:         "_env:AVSPORT:443"
+  port:    "_env:AVSPORT:443"
-  user:         "_env:AVSUSER:fradrive"
+  user:    "_env:AVSUSER:fradrive"
-  pass:         "_env:AVSPASS:\"0000\""
+  pass:    "_env:AVSPASS:"
-  timeout:      "_env:AVSTIMEOUT:42"
-  cache-expiry: "_env:AVSCACHEEXPIRY:420"
 
 lpr:
   host:    "_env:LPRHOST:fravm017173.fra.fraport.de"
@@ -208,6 +207,9 @@ 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
@@ -276,8 +278,8 @@ user-defaults:
   max-favourites:      0
   max-favourite-terms: 2
   theme:               Default
-  date-time-format:    "%d.%m.%Y %R"
+  date-time-format:    "%d %b %y %R"
-  date-format:         "%d.%m.%y"
+  date-format:         "%d %b %Y"
   time-format:         "%R"
   download-files:      false
   warning-days:        1209600
@@ -319,6 +321,17 @@ 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

config/test-settings.yml

@@ -16,4 +16,5 @@ log-settings:
 auth-dummy-login: true
 server-session-acid-fallback: true
 
-job-workers: 20
+job-cron-interval: null
+job-workers: 1

docker/backend/Dockerfile

@@ -0,0 +1,38 @@
+ARG FROM_IMG=docker.io/library/haskell
+ARG FROM_TAG=8.10.4
+
+FROM ${FROM_IMG}:${FROM_TAG}
+
+ENV LANG=de_DE.UTF-8
+
+# compile-time dependencies
+RUN --mount=type=cache,target=/var/cache/apt,sharing=locked \
+--mount=type=cache,target=/var/lib/apt,sharing=locked \
+apt-get -y update && apt-get install -y libpq-dev libsodium-dev
+# RUN apt-get -y update && apt-get -y install llvm
+# RUN apt-get -y update && apt-get -y install g++ libghc-zlib-dev libpq-dev libsodium-dev pkg-config
+# RUN apt-get -y update && DEBIAN_FRONTEND=noninteractive apt-get install -y --no-install-recommends tzdata
+RUN --mount=type=cache,target=/var/cache/apt,sharing=locked \
+--mount=type=cache,target=/var/lib/apt,sharing=locked \
+apt-get -y update && apt-get install -y --no-install-recommends locales locales-all
+
+# run-time dependencies for uniworx binary
+RUN --mount=type=cache,target=/var/cache/apt,sharing=locked \
+--mount=type=cache,target=/var/lib/apt,sharing=locked \
+apt-get -y update && apt-get -y install fonts-roboto
+# RUN apt-get -y update && apt-get -y install pdftk
+RUN --mount=type=cache,target=/var/cache/apt,sharing=locked \
+--mount=type=cache,target=/var/lib/apt,sharing=locked \
+apt-get -y update && apt-get -y install texlive-latex-recommended texlive-luatex texlive-plain-generic texlive-lang-german texlive-lang-english
+
+ARG PROJECT_DIR=/fradrive
+ENV PROJECT_DIR=${PROJECT_DIR}
+RUN mkdir -p "${PROJECT_DIR}"; chmod -R 7777 "${PROJECT_DIR}"
+WORKDIR ${PROJECT_DIR}
+ENV HOME=${PROJECT_DIR}
+ENV STACK_ROOT="${PROJECT_DIR}/.stack"
+
+RUN if [ ! -z "${IN_CI}" ]; then \
+  stack install yesod-bin; \
+  stack install hpack; \
+fi

docker/fradrive/Dockerfile

@@ -14,12 +14,10 @@ ENV DEBIAN_FRONTEND=noninteractive
 ENV TZ=Etc/UTC
 RUN apt-get update && apt-get -y install libpq-dev
 RUN apt-get update && apt-get -y install libsodium-dev
-RUN apt-get update && apt-get -y install fonts-roboto
 # TODO: minimize texlive dependencies, switch to basic schemes where possible
 RUN apt-get update && apt-get -y install \
-    texlive-full \
+    texlive-latex-base \
     texlive-luatex \
-    texlive-plain-generic \
     texlive-fonts-recommended \
     texlive-fonts-extra \
     texlive-lang-english \

docker/postgres/Dockerfile

@@ -0,0 +1,9 @@
+FROM docker.io/postgres:12
+
+# Allow for connecting to database without password authentication
+ENV POSTGRES_HOST_AUTH_METHOD=trust
+
+COPY --chown=postgres:postgres docker/postgres/pg_hba.conf /tmp/pg_hba.conf
+COPY --chown=postgres:postgres docker/postgres/postgresql.conf /tmp/postgresql.conf
+COPY docker/postgres/pgconfig.sh /docker-entrypoint-initdb.d/_pgconfig.sh
+COPY --chown=postgres:postgres docker/postgres/schema.sql /docker-entrypoint-initdb.d/schema.sql

docker/postgres/initdb.sh

@@ -0,0 +1,14 @@
+#!/bin/bash
+
+# Init and start the postgres daemon
+initdb --no-locale
+pg_ctl start -w -o "-c listen_addresses='*' -c unix_socket_permissions=0700 -c max_connections=9990 -c shared_preload_libraries=pg_stat_statements -c session_preload_libraries=auto_explain -c auto_explain.log_min_duration=100ms"
+POSTGRID=`cat /var/lib/postgresql/data/postmaster.pid | perl -le '<>=~m#(\d+)# and print $1'`
+
+# Create uniworx and uniworx_test database
+psql -f /schema.sql postgres
+
+# Wait for postgres daemon to terminate
+while [ -e /proc/$POSTGRID ]; do
+    sleep 0.5;
+done

docker/postgres/pg_hba.conf

@@ -0,0 +1,3 @@
+local all all trust
+host all all 0.0.0.0/0 trust
+host all all ::1/128 trust

docker/postgres/pgconfig.sh

@@ -0,0 +1,6 @@
+#!/usr/bin/env bash
+
+cat /tmp/pg_hba.conf > /var/lib/postgresql/data/pg_hba.conf
+cat /tmp/postgresql.conf > /var/lib/postgresql/data/postgresql.conf
+
+echo "Custom pg_hba.conf and postgresql.conf successfully deployed."

docker/postgres/postgresql.conf

@@ -0,0 +1,6 @@
+listen_addresses='*'
+unix_socket_permissions=0700
+max_connections=9990
+shared_preload_libraries=pg_stat_statements
+session_preload_libraries=auto_explain
+auto_explain.log_min_duration=100ms

docker/postgres/schema.sql

@@ -0,0 +1,5 @@
+CREATE USER uniworx WITH SUPERUSER PASSWORD 'uniworx';
+CREATE DATABASE uniworx_test;
+GRANT ALL ON DATABASE uniworx_test TO uniworx;
+CREATE DATABASE uniworx;
+GRANT ALL ON DATABASE uniworx TO uniworx;

esbuild.config.mjs

@@ -20,8 +20,8 @@ await esbuild.build({
   minify: true,
   sourcemap: true,
   entryPoints: {
-    main: './src/main.js',
+    main: './frontend/src/main.js',
-    polyfill: './src/polyfill.js',
+    polyfill: './frontend/src/polyfill.js',
   },
   outdir: staticDir,
   plugins: [
@@ -48,20 +48,19 @@ await esbuild.build({
     copy({
       resolveFrom: 'cwd',
       assets: {
-        from: [ './robots.txt' ],
+        from: [ './config/robots.txt' ],
         to: wellKnownDirs,
       },
     }),
     // ...['de-de-formal','en-eu'].map((lang) => manifestPlugin({
     manifestPlugin({
       filename: 'manifest.json',
-      path: '.',
+      path: 'config',
       // metadata: { timestamp: new Date(), module: 'myapp', type: 'esm', },
       processOutput(assets) {
         const orderAssets = {
           main: assets['main'],
-          polyfill: assets['polyfill'],
+          ...assets
-          icons: { "svg": assets['']['svg'][0] },
         };
         return JSON.stringify(orderAssets, null, '  ');
       },