fix(avs): fix #225 by skipping firm updates entirely if AVS FirmInfo is unchanged for previously seen values for AVS User to be updated

Note: noticed while working on #225

.gitlab-ci.yml

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor@kleen.consulting>
+# SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor@kleen.consulting>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -35,7 +35,6 @@ node dependencies:
   stage: frontend:build
   script:
     - nix -L build -o result ".#uniworxNodeDependencies"
-    - nix-store --gc
     - nix-store --export $(nix-store -qR result) | xz -T0 -2 > node-dependencies.nar.xz
   before_script: &nix-before
     - git config --global init.defaultBranch master
@@ -55,12 +54,8 @@ node dependencies:
 well known:
   stage: frontend:build
   script:
-#   - xzcat node-dependencies.nar.xz > node-dependencies-debug.nar
-#   - nix-shell -p util-linux --command "hexdump -C node-dependencies-debug.nar | head -n 10"
-#   - nix nar ls node-dependencies-debug.nar /
     - xzcat node-dependencies.nar.xz | nix-store --import
     - nix -L build -o result ".#uniworxWellKnown"
-    - nix-store --gc
     - nix-store --export $(nix-store -qR result) | xz -T0 -2 > well-known.nar.xz
   before_script: *nix-before
   needs:
@@ -80,7 +75,6 @@ frontend:
     - xzcat node-dependencies.nar.xz | nix-store --import
     - xzcat well-known.nar.xz | nix-store --import
     - nix -L build -o result ".#uniworxFrontend"
-    - nix-store --gc
     - nix-store --export $(nix-store -qR result) | xz -T0 -2 > frontend.nar.xz
   before_script: *nix-before
   needs:
@@ -101,7 +95,6 @@ uniworx:lib:uniworx:
   script:
     - xzcat frontend.nar.xz | nix-store --import
     - nix -L build -o result ".#uniworx:lib:uniworx"
-    - nix-store --gc
     - nix-store --export $(nix-store -qR result) | xz -T0 -2 > uniworx:lib:uniworx.nar.xz
   before_script: *nix-before
   needs:
@@ -124,7 +117,6 @@ uniworx:exe:uniworx:
   script:
     - xzcat uniworx:lib:uniworx.nar.xz | nix-store --import
     - nix -L build -o result ".#uniworx:exe:uniworx"
-    - nix-store --gc
     - nix-store --export $(nix-store -qR result) | xz -T0 -2 > uniworx:exe:uniworx.nar.xz
   before_script: *nix-before
   needs:
@@ -149,7 +141,6 @@ uniworx:exe:uniworxdb:
   script:
     - xzcat uniworx:lib:uniworx.nar.xz | nix-store --import
     - nix -L build -o result ".#uniworx:exe:uniworxdb"
-    - nix-store --gc
     - nix-store --export $(nix-store -qR result) | xz -T0 -2 > uniworx:exe:uniworxdb.nar.xz
   before_script: *nix-before
   needs:
@@ -174,7 +165,6 @@ uniworx:exe:uniworxload:
   script:
     - xzcat uniworx:lib:uniworx.nar.xz | nix-store --import
     - nix -L build -o result ".#uniworx:exe:uniworxload"
-    - nix-store --gc
     - nix-store --export $(nix-store -qR result) | xz -T0 -2 > uniworx:exe:uniworxload.nar.xz
   before_script: *nix-before
   needs:
@@ -217,13 +207,8 @@ container:
   stage: container:build
   script:
     - xzcat uniworx:exe:uniworx.nar.xz | nix-store --import
-    # - &container-remove-nodejs
+    - cp -pr --reflink=auto -L $(nix build --print-out-paths  ".#uniworxDocker") uniworx.tar.gz
-    #   "for i in `ls /nix/store/ | grep -E -i '^[a-z0-9]+-nodejs-'` ; do ( nix store delete --ignore-liveness \"/nix/store/$i\" || ( echo \"Could not remove NodeJS from /nix/store/ due to: \" && ( nix-store --query --roots \"/nix/store/$i\" | cat ) && echo \"Removing NodeJS by brute force...\" && rm -rf \"/nix/store/$i\" ) ) ; done"
-    - cp -p --reflink=auto -L $(nix build --print-out-paths  ".#uniworxDocker") uniworx.tar.gz
   before_script: *nix-before
-  # TODO: reintroduce working version of after_script
-  # after_script: &container-fail-on-nodejs
-  #  - (ls /nix/store/ | grep -E -i '^[a-z0-9]+-nodejs-') && (echo "NodeJS remainder in container /nix/store!" 1>&2; exit 1)
   needs:
     - job: node dependencies # transitive
       artifacts: false
@@ -250,10 +235,8 @@ test container:
   stage: container:build
   script:
     - xzcat uniworx:exe:uniworx.nar.xz | nix-store --import
-    # - *container-remove-nodejs
+    - cp -pr --reflink=auto -L $(nix build --print-out-paths  ".#uniworxTestDocker") uniworx.tar.gz
-    - cp -p --reflink=auto -L $(nix build --print-out-paths  ".#uniworxTestDocker") uniworx.tar.gz
   before_script: *nix-before
-  # after_script: *container-fail-on-nodejs
   needs:
     - job: node dependencies # transitive
       artifacts: false
@@ -276,128 +259,6 @@ test container:
   interruptible: true
   rules: &test-release-rules
     - if: $CI_COMMIT_TAG =~ /^t/
-dev container:
-  stage: container:build
-  script:
-    - xzcat uniworx:exe:uniworx.nar.xz | nix-store --import
-    - cp -p --reflink=auto -L $(nix build --print-out-paths  ".#uniworxDevDocker") uniworx.tar.gz
-  before_script: *nix-before
-  needs:
-    - job: node dependencies # transitive
-      artifacts: false
-    - job: well known # transitive
-      artifacts: false
-    - job: frontend # tranitive
-      artifacts: false
-    - job: uniworx:lib:uniworx # transitive
-      artifacts: false
-    - job: uniworx:exe:uniworx
-      artifacts: true
-    - job: check # sanity
-      artifacts: false
-  artifacts:
-    paths:
-      - uniworx.tar.gz
-    name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
-    expire_in: "1 day"
-  retry: 2
-  interruptible: true
-  rules: &dev-release-rules
-    - if: $CI_COMMIT_TAG =~ /^d/
-
-sanitize container:
-  stage: container:build
-  needs:
-    - job: node dependencies # transitive
-      artifacts: false
-    - job: well known # transitive
-      artifacts: false
-    - job: frontend # transitive
-      artifacts: false
-    - job: uniworx:lib:uniworx # transitive
-      artifacts: false
-    - job: uniworx:exe:uniworx # transitive
-      artifacts: false
-    - job: check # sanity
-      artifacts: false
-    - job: container
-      artifacts: true
-  before_script: *nix-before
-  script:
-    - nix shell nixpkgs#perl --command ./.gitlab-ci/sanitize-docker.pl
-  after_script:
-    - tar xzvf uniworx-sanitized.tar.gz
-    - for i in `tar tf */layer.tar | grep 'nix/store/[0-9a-z]*-nodejs'`; do echo "NodeJS remainer found in /nix/store!"; echo "$i"; exit 1; done
-  artifacts:
-    paths:
-      - uniworx-sanitized.tar.gz
-    name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
-    expire_in: "1 day"
-  retry: 2
-  interruptible: true
-  rules: *release-rules
-sanitize test container:
-  stage: container:build
-  needs:
-    - job: node dependencies # transitive
-      artifacts: false
-    - job: well known # transitive
-      artifacts: false
-    - job: frontend # transitive
-      artifacts: false
-    - job: uniworx:lib:uniworx # transitive
-      artifacts: false
-    - job: uniworx:exe:uniworx # transitive
-      artifacts: false
-    - job: check # sanity
-      artifacts: false
-    - job: test container
-      artifacts: true
-  before_script: *nix-before
-  script:
-    - nix shell nixpkgs#perl --command ./.gitlab-ci/sanitize-docker.pl
-  after_script:
-    - tar xzvf uniworx-sanitized.tar.gz
-    - for i in `tar tf */layer.tar | grep 'nix/store/[0-9a-z]*-nodejs'`; do echo "NodeJS remainer found in /nix/store!"; echo "$i"; exit 1; done
-  artifacts:
-    paths:
-      - uniworx-sanitized.tar.gz
-    name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
-    expire_in: "1 day"
-  retry: 2
-  interruptible: true
-  rules: *test-release-rules
-sanitize dev container:
-  stage: container:build
-  needs:
-    - job: node dependencies # transitive
-      artifacts: false
-    - job: well known # transitive
-      artifacts: false
-    - job: frontend # transitive
-      artifacts: false
-    - job: uniworx:lib:uniworx # transitive
-      artifacts: false
-    - job: uniworx:exe:uniworx # transitive
-      artifacts: false
-    - job: check # sanity
-      artifacts: false
-    - job: dev container
-      artifacts: true
-  before_script: *nix-before
-  script:
-    - nix shell nixpkgs#perl --command ./.gitlab-ci/sanitize-docker.pl
-  after_script:
-    - tar xzvf uniworx-sanitized.tar.gz
-    - for i in `tar tf */layer.tar | grep 'nix/store/[0-9a-z]*-nodejs'`; do echo "NodeJS remainer found in /nix/store!"; echo "$i"; exit 1; done
-  artifacts:
-    paths:
-      - uniworx-sanitized.tar.gz
-    name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
-    expire_in: "1 day"
-  retry: 2
-  interruptible: true
-  rules: *dev-release-rules
 
 parse changelog:
   stage: prepare release
@@ -450,27 +311,25 @@ upload container:
   stage: release
   image: quay.io/skopeo/stable:latest
   script:
-    - skopeo --insecure-policy copy --dest-creds "${CI_REGISTRY_USER}:${CI_JOB_TOKEN}" docker-archive://$(pwd)/uniworx-sanitized.tar.gz docker://${CI_REGISTRY_IMAGE}:${VERSION}
+    - skopeo --insecure-policy copy --dest-creds "${CI_REGISTRY_USER}:${CI_JOB_TOKEN}" docker-archive://$(pwd)/uniworx.tar.gz docker://${CI_REGISTRY_IMAGE}:${VERSION}
     - skopeo --insecure-policy copy --src-creds "${CI_REGISTRY_USER}:${CI_JOB_TOKEN}" --dest-creds "${CI_REGISTRY_USER}:${CI_JOB_TOKEN}" docker://${CI_REGISTRY_IMAGE}:${VERSION} docker://${CI_REGISTRY_IMAGE}:latest
   needs:
     - job: node dependencies # transitive
       artifacts: false
     - job: well known # transitive
       artifacts: false
-    - job: frontend # transitive
+    - job: frontend # tranitive
       artifacts: false
     - job: uniworx:lib:uniworx # transitive
       artifacts: false
     - job: uniworx:exe:uniworx # transitive
       artifacts: false
-    - job: container # transitive
+    - job: container
-      artifacts: false
+      artifacts: true
     - job: parse changelog
       artifacts: true
     - job: check # sanity
       artifacts: false
-    - job: sanitize container
-      artifacts: true
   rules: *release-rules
   retry: 2
 upload test container:
@@ -479,56 +338,27 @@ upload test container:
   stage: release
   image: quay.io/skopeo/stable:latest
   script:
-    - skopeo --insecure-policy copy --dest-creds "${CI_REGISTRY_USER}:${CI_JOB_TOKEN}" docker-archive://$(pwd)/uniworx-sanitized.tar.gz docker://${CI_REGISTRY}/fradrive/fradrive/test:${CI_COMMIT_REF_NAME}
+    - skopeo --insecure-policy copy --dest-creds "${CI_REGISTRY_USER}:${CI_JOB_TOKEN}" docker-archive://$(pwd)/uniworx.tar.gz docker://${CI_REGISTRY}/fradrive/fradrive/test:${CI_COMMIT_REF_NAME}
     - skopeo --insecure-policy copy --src-creds "${CI_REGISTRY_USER}:${CI_JOB_TOKEN}" --dest-creds "${CI_REGISTRY_USER}:${CI_JOB_TOKEN}" docker://${CI_REGISTRY}/fradrive/fradrive/test:${CI_COMMIT_REF_NAME} docker://${CI_REGISTRY}/fradrive/fradrive/test:latest
   needs:
     - job: node dependencies # transitive
       artifacts: false
     - job: well known # transitive
       artifacts: false
-    - job: frontend # transitive
+    - job: frontend # tranitive
       artifacts: false
     - job: uniworx:lib:uniworx # transitive
       artifacts: false
     - job: uniworx:exe:uniworx # transitive
       artifacts: false
-    - job: test container # transitive
+    - job: test container
-      artifacts: false
+      artifacts: true
     - job: parse test changelog
       artifacts: true
     - job: check # sanity
       artifacts: false
-    - job: sanitize test container
-      artifacts: true
   rules: *test-release-rules
   retry: 2
-upload dev container:
-  variables:
-    GIT_STRATEGY: none
-  stage: release
-  image: quay.io/skopeo/stable:latest
-  script:
-    - skopeo --insecure-policy copy --dest-creds "${CI_REGISTRY_USER}:${CI_JOB_TOKEN}" docker-archive://$(pwd)/uniworx-sanitized.tar.gz docker://${CI_REGISTRY}/fradrive/fradrive/dev:${CI_COMMIT_REF_NAME}
-    - skopeo --insecure-policy copy --src-creds "${CI_REGISTRY_USER}:${CI_JOB_TOKEN}" --dest-creds "${CI_REGISTRY_USER}:${CI_JOB_TOKEN}" docker://${CI_REGISTRY}/fradrive/fradrive/dev:${CI_COMMIT_REF_NAME} docker://${CI_REGISTRY}/fradrive/fradrive/dev:latest
-  needs:
-    - job: node dependencies # transitive
-      artifacts: false
-    - job: well known # transitive
-      artifacts: false
-    - job: frontend # transitive
-      artifacts: false
-    - job: uniworx:lib:uniworx # transitive
-      artifacts: false
-    - job: uniworx:exe:uniworx # transitive
-      artifacts: false
-    - job: dev container # transitive
-      artifacts: false
-    - job: check # sanity
-      artifacts: false
-    - job: sanitize dev container
-      artifacts: true
-  rules: *dev-release-rules
-  retry: 2
 
 release:
   variables:
@@ -564,18 +394,3 @@ test release:
       artifacts: false
     - job: parse test changelog
       artifacts: true
-dev release:
-  variables:
-    GIT_STRATEGY: none
-  stage: release
-  image: registry.gitlab.com/gitlab-org/release-cli:latest
-  rules: *dev-release-rules
-  script:
-    - echo "Will create dev release ${VERSION}-dev..."
-  release:
-    name: "${VERSION}-dev"
-    tag_name: '$CI_COMMIT_TAG'
-    description: .current-changelog.md
-  needs:
-    - job: check # sanity
-      artifacts: false

.gitlab-ci/sanitize-docker.pl

@@ -1,272 +0,0 @@
-#!/usr/bin/env perl
-
-use strict;
-use warnings;
-
-use Data::Dumper;
-
-print "Sanitize script for node removal from container.\n";
-
-system("pwd");
-{
-  my @l = (".","..");
-  for(1..8) {
-    push @l, (("../" x $_)."..")
-  }
-  for(@l) {
-    my $cmd = "ls -ld $_";
-    print "running: $cmd\n";
-    system $cmd;
-  }
-}
-
-my $tmpdir = "tmp-sanitize";
-
-die "Has already run, abort" if -e $tmpdir;
-
-mkdir $tmpdir;
-
-chmodWrap(0755, $tmpdir);
-chdir($tmpdir);
-system("ln -s ../uniworx.tar.gz .");
-system("tar xzvf uniworx.tar.gz");
-chmodWrap(0755, '.'); # tar can change the rights of '.' if it contains an entry for '.' with other rights
-
-my %truerights = ();
-storeRightsMake7(".");
-
-#print "=== Extended rights:\n";
-#system("ls -l *");
-#resetRights(".");
-#print "=== Reset rights:\n";
-#system("ls -l *");
-
-sub chmodWrap {
-  my ($mode, $fn) = @_;
-  my $tries = 0;
-  die "file '$fn' does not exist; cannot change its permissions to $mode" unless -e $fn;
-  RIGHTS: {
-    chmod($mode, $fn);
-    my $ismode = (stat($fn))[2];
-    my $fm = $ismode % 512;
-    if($fm != $mode) {
-      if($tries++ > 20) {
-        die "Problem with file permissions, abort"
-      }
-      warn sprintf "File rights were meant to be set, but were not updated properly for file '%s', is %03o but was set to %03o; try again in 1 second";
-      sleep 1;
-      redo RIGHTS;
-    }
-  }
-}
-
-# 
-sub storeRightsMake7 {
-  my ($pwd) = @_;
-  my $dh = undef;
-  opendir($dh, $pwd) or die "Could not read dir '$pwd', because: $!";
-  while(my $fn = readdir($dh)) {
-    next if $fn=~m#^\.\.?$#;
-    #perl -le 'my $dh = undef;opendir($dh, ".");while(my $fn = readdir($dh)) { my $mode = (stat($fn))[2];my $fm = $mode % 512;my $fmo=sprintf("%03o",$fm);print "$fn -> $fmo" }'
-    my $fullname = "$pwd/$fn";
-    my $mode = (stat($fullname))[2];
-    my $fm = $mode % 512;
-    #my $fmo = sprintf("%03o",$fm);
-    $truerights{$fullname} = $fm;
-    chmodWrap(($fm | 0700), $fullname);
-    storeRightsMake7($fullname) if -d $fullname;
-  }
-}
-
-sub resetRights {
-  my ($pwd) = @_;
-  print "Resetting rights to:\n" if '.' eq $pwd;
-  print Data::Dumper::Dumper(\%truerights);
-  my $dh = undef;
-  opendir($dh, $pwd) or die "Could not read dir '$pwd', because: $!";
-  while(my $fn = readdir($dh)) {
-    next if $fn=~m#^\.\.?$#;
-    #perl -le 'my $dh = undef;opendir($dh, ".");while(my $fn = readdir($dh)) { my $mode = (stat($fn))[2];my $fm = $mode % 512;my $fmo=sprintf("%03o",$fm);print "$fn -> $fmo" }'
-    my $fullname = "$pwd/$fn";
-    printf("  set rights of '$fullname' back to %03o\n", $truerights{$fullname});
-    chmodWrap($truerights{$fullname}, $fullname);
-    resetRights($fullname) if -d $fullname;
-  }
-}
-
-sub renameWithRights {
-  my ($from, $to) = @_;
-  print "  rename file '$from' to '$to'\n";
-  my %oldrights = %truerights;
-  %truerights = ();
-  while(my ($k,$v) = each %oldrights) {
-    $k =~ s#^\./\Q$from\E#./$to#;
-    $truerights{$k} = $v;
-  }
-  #my $rights = $truerights{$from};
-  #delete $truerights{$from};
-  rename($from, $to) or die "Could not rename '$from' to '$to', because $!";
-  my $waittimer = 20;
-  while(-e $from || not(-e $to) and $waittimer-- > 0) {
-    sleep 1
-  }
-  die "rename file from '$from' to '$to', but it is still there" if -e $from;
-  die "rename file from '$from' to '$to', but there is no file under the new name" unless -e $to;
-  #$truerights{$to} = $rights
-}
-
-print Data::Dumper::Dumper(\%truerights);
-#exit 0;
-
-# Checksummen:
-# outerjson  c27f -- toplevel $outerjson.json, by sha256sum $outerjson.json
-# imageid    d940 -- toplevel verzeichnis mit der layer darin; doc says: Each image’s ID is given by the SHA256 hash of its configuration JSON.
-#                    we'll try as configuration "remove nodejs $oldhash"
-#                    or we just use a random number ;)
-# layertar   fd3d -- doc says: Each image’s ID is given by the SHA256 hash of its configuration JSON.
-#
-##### FOUND
-# outerjson c27f64c8de183296ef409baecc27ddac8cd4065aac760b1b512caf482ad782dd -- in manifest.json
-# imageid   d940253667b5ab47060e8bf537bd5b3e66a2447978f3c784a22b115a262fccbf -- in manifest.json
-# imageid   d940253667b5ab47060e8bf537bd5b3e66a2447978f3c784a22b115a262fccbf -- as toplevel dirname
-# outerjson c27f64c8de183296ef409baecc27ddac8cd4065aac760b1b512caf482ad782dd -- as toplevel filename
-# imageid   d940253667b5ab47060e8bf537bd5b3e66a2447978f3c784a22b115a262fccbf -- in $layerdir/json
-# layertar  fd3d3cdf4ece09864ac933aa664eb5f397cf5ca28652125addd689726f8485cd -- in $outerjson.json
-# 
-#
-##### COMPUTE
-# toplevel
-# outerjson  c27f64c8de183296ef409baecc27ddac8cd4065aac760b1b512caf482ad782dd  $outerjson.json
-#            b21db3fcc85b23d91067a2a5834e114ca9eec0364742c8680546f040598d8cd9  manifest.json
-#            238f234e3a1ddb27a034f4ee1e59735175741e5cc05673b5dd41d9a42bac2ebd  uniworx.tar.gz
-# in $layerdir/
-#            028c1e8d9688b420f7316bb44ce0e26f4712dc21ef93c5af8000c102b1405ad4  json
-# layertar   fd3d3cdf4ece09864ac933aa664eb5f397cf5ca28652125addd689726f8485cd  layer.tar
-#            d0ff5974b6aa52cf562bea5921840c032a860a91a3512f7fe8f768f6bbe005f6  VERSION
-#
-#
-# sha256sum layer.tar fd3d3cdf4ece09864ac933aa664eb5f397cf5ca28652125addd689726f8485cd
-
-my ($outerjson, $imageid) = ();
-
-{
-  my $dirh = undef;
-  opendir($dirh, '.') or die "Could not read dir '.', because: $!";
-  while(my $fn = readdir($dirh)) {
-    next if $fn=~m#^\.#;
-    if($fn=~m#(.{16,})\.json#) { # it shall match on hash sums but not for example on manifest.json
-      $outerjson = $1;
-      next
-    }
-    if($fn=~m#^[0-9a-f]{64}$#) {
-      $imageid = $fn
-    }
-  }
-}
-
-die "Bad archive, could not found expected files and directories" unless defined($outerjson) and defined($imageid);
-
-#system("pwd");
-#print "will run: sha256sum $imageid/layer.tar\n";
-
-my $oldLayerdir = qx(sha256sum $imageid/layer.tar);
-#print "oldLayerdir is for now $oldLayerdir\n\n";
-$oldLayerdir =~ m#^([0-9a-f]{64}).*$# or die "layer.tar not found or sha256sum not installed!";
-$oldLayerdir = $1;
-
-# tar --delete --file layer.tar nix/store/cdalbhzm3z4gz07wyg89maprdbjc4yah-nodejs-14.17.0
-my $layerContent = qx(tar -tf $imageid/layer.tar);
-
-my @rms = $layerContent=~m#^((?:\./)?nix/store/[a-z0-9]+-(?:nodejs|openjdk|ghc)-[^/]+/)$#gm;
-
-print "rm <<$_>>\n" for @rms;
-
-system("tar --delete --file $imageid/layer.tar '$_'") for @rms;
-
-
-### Deconstruction finished, now lets put everything together again after fixing the checksums
-
-
-my $newImageId = qx(echo 'remove nodejs $imageid' | sha256sum);
-$newImageId =~ m#^([0-9a-f]{64}).*$# or die "sha256sum not installed!";
-$newImageId = $1;
-
-my $newLayerdir = qx(sha256sum $imageid/layer.tar);
-$newLayerdir =~ m#^([0-9a-f]{64}).*$# or die "sha256sum not installed!";
-$newLayerdir = $1;
-
-# new outerjson is computed later, as we first have to change its content
-
-sub cautionWaiter {
-  # some file operations give the impression that they are not instant.
-  # Hence, we wait here a bit to see if that fixes stuff
-  #sleep 5; # seems not to be the reason
-}
-
-sub replaceInFile {
-  my ($filename, $replacer) = @_;
-  return unless -e $filename;
-  my $fh = undef;
-  open($fh, '<', $filename) or die "Could not read $filename, because: $!";
-  my $content = join '', <$fh>;
-  close $fh;
-  keys %$replacer;
-  while(my ($k,$v) = each %$replacer) {
-    $content=~s#\Q$k\E#$v#g;
-  }
-  my $wh = undef;
-  open($wh, '>', $filename) or die "Could not write $filename, because: $!";
-  print $wh $content;
-  close $wh;
-}
-
-my %replacer = (
-  $oldLayerdir => $newLayerdir,
-  $imageid => $newImageId,
-);
-
-replaceInFile("$imageid/json", \%replacer);
-replaceInFile("$outerjson.json", \%replacer);
-
-cautionWaiter();
-
-my $newOuterjson = qx(sha256sum '$outerjson.json');
-$newOuterjson =~ m#^([0-9a-f]{64}).*$# or die "sha256sum not installed!";
-$newOuterjson = $1;
-
-cautionWaiter();
-
-renameWithRights("$outerjson.json", "$newOuterjson.json");
-$replacer{$outerjson} = $newOuterjson;
-
-replaceInFile("manifest.json", \%replacer);
-
-replaceInFile("repositories", \%replacer);
-
-cautionWaiter();
-renameWithRights($imageid, $newImageId);
-
-cautionWaiter();
-
-
-
-
-
-resetRights(".");
-
-
-system("find");
-
-unlink("uniworx.tar.gz");
-
-system("tar czvf uniwox-rmnodejs.tar.gz *");
-
-cautionWaiter();
-print "Debug output, content of container:\n";
-system("tar tzvf uniwox-rmnodejs.tar.gz");
-
-cautionWaiter();
-#unlink("../uniworx.tar.gz");
-
-system("cp uniwox-rmnodejs.tar.gz ../uniworx-sanitized.tar.gz");
-

.ports/assign.hs

@@ -1,64 +0,0 @@
--- SPDX-FileCopyrightText: 2024 David Mosbach <david.mosbach@uniworx.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# Language OverloadedStrings, LambdaCase, TypeApplications #-}
-
-import Data.Text (Text)
-import qualified Data.Text as T
-import System.Directory
-import System.Environment
-import System.IO
-
-main :: IO ()
-main = getArgs >>= \case
-  ["--assign", offsetFile] -> parseOffsets offsetFile >>= uncurry nextOffset
-  ["--remove", offset] -> removeOffset offset
-  _ -> fail "unsupported args"
-
-parseOffsets :: FilePath -> IO (Int,Int)
-parseOffsets offsetFile = do
-  user <- T.pack <$> getEnv "USER"
-  let pred x = "//" `T.isPrefixOf` x || T.null (T.strip x)
-      tokenise = map (filter (not . pred) . T.lines) . T.split (=='#')
-      extract = map tail . filter (\u -> not (null u) && user == (T.strip $ head u))
-  ((extract . tokenise . T.pack) <$> readFile offsetFile) >>= \case
-    [[min,max]] -> return (read $ T.unpack min, read $ T.unpack max)
-    x -> print x >> fail "malformed offset file"
-
-nextOffset :: Int -> Int -> IO ()
-nextOffset min max
-  | min > max = nextOffset max min
-  | otherwise = do
-      home <- getEnv "HOME"
-      offset <- findFile [home] ".port-offsets" >>= \case
-        Nothing   -> writeFile (home ++ "/.port-offsets") (show min) >> return min
-        Just path -> do
-          used <- (map (read @Int) . filter (not . null) . lines) <$> readFile path
-          o <- next min max used
-          appendFile path ('\n' : show o)
-          return o
-      print offset
-        where
-          next :: Int -> Int -> [Int] -> IO Int
-          next min max used
-            | min > max = fail "all offsets currently in use"
-            | min `elem` used = next (min+1) max used
-            | otherwise = return min
-
-removeOffset :: String -> IO ()
-removeOffset offset = do
-  home <- getEnv "HOME"
-  findFile [home] ".port-offsets" >>= \case
-    Nothing   -> fail "offset file does not exist"
-    Just path -> do
-      remaining <- (filter (/= offset) . lines) <$> readFile path
-      run <- getEnv "XDG_RUNTIME_DIR"
-      (tempPath, fh) <- openTempFile run ".port-offsets"
-      let out = unlines remaining
-      hPutStr fh $ out
-      case T.null (T.strip $ T.pack out) of
-        True -> removeFile path
-        False -> writeFile path $ out
-      removeFile tempPath
-

.ports/offsets

@@ -1,24 +0,0 @@
-// SPDX-FileCopyrightText: 2024 David Mosbach <david.mosbach@uniworx.de>
-//
-// SPDX-License-Identifier: AGPL-3.0-or-later
-
-# gkleen
-  -1000
-  -950
-
-# ishka
-  -949
-  -899
-
-# jost
-  -898
-  -848
-
-# mosbach
-  -847
-  -797
-
-# savau
-  -796
-  -746
-

config/settings.yml

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@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-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -25,8 +25,8 @@ mail-from:
 mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
 mail-use-replyto-instead-sender: "_env:MAIL_USES_REPLYTO:true"
 mail-reroute-to: 
-  name:         "_env:MAIL_REROUTE_TO_NAME:"
+ name:         "_env:MAIL_REROUTE_TO_NAME:"
-  email:        "_env:MAIL_REROUTE_TO_EMAIL:"
+ email:        "_env:MAIL_REROUTE_TO_EMAIL:"
 #mail-verp:
 #  separator:    "_env:VERP_SEPARATOR:+"
 #  prefix:       "_env:VERP_PREFIX:bounce"
@@ -66,7 +66,7 @@ keep-unreferenced-files: 86400
 health-check-interval:
   matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600"
   http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600"
-  ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600" # TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics
+  ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600"
   smtp-connect: "_env:HEALTHCHECK_INTERVAL_SMTP_CONNECT:600"
   widget-memcached: "_env:HEALTHCHECK_INTERVAL_WIDGET_MEMCACHED:600"
   active-job-executors: "_env:HEALTHCHECK_INTERVAL_ACTIVE_JOB_EXECUTORS:60"
@@ -77,10 +77,14 @@ health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can rea
 health-check-active-job-executors-timeout: "_env:HEALTHCHECK_ACTIVE_JOB_EXECUTORS_TIMEOUT:5"
 health-check-active-widget-memcached-timeout: "_env:HEALTHCHECK_ACTIVE_WIDGET_MEMCACHED_TIMEOUT:2"
 health-check-smtp-connect-timeout: "_env:HEALTHCHECK_SMTP_CONNECT_TIMEOUT:5"
-health-check-ldap-admins-timeout: "_env:HEALTHCHECK_LDAP_ADMINS_TIMEOUT:60" # TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics
+health-check-ldap-admins-timeout: "_env:HEALTHCHECK_LDAP_ADMINS_TIMEOUT:60"
 health-check-http-reachable-timeout: "_env:HEALTHCHECK_HTTP_REACHABLE_TIMEOUT:2"
 health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER_CONFIG_TIMEOUT:2"
 
+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
 
@@ -88,8 +92,8 @@ 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-enqueue-hour: 16
-# job-lms-qualifications-dequeue-hour: 3
+job-lms-qualifications-dequeue-hour: 4
 
 log-settings:
   detailed:      "_env:DETAILED_LOGGING:false"
@@ -126,47 +130,24 @@ database:
   database: "_env:PGDATABASE:uniworx"
   poolsize: "_env:PGPOOLSIZE:990"
 
-auto-db-migrate: "_env:AUTO_DB_MIGRATE:true"
+auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
 
-# External sources used for user authentication and userdata lookups
+ldap:
-user-auth:
+  - host:    "_env:LDAPHOST:"
-# mode: single-source
+    tls:     "_env:LDAPTLS:"
-  protocol: azureadv2
+    port:    "_env:LDAPPORT:389"
-  config:
+    user:    "_env:LDAPUSER:"
-    client-id:     "_env:AZURECLIENTID:00000000-0000-0000-0000-000000000000"
+    pass:    "_env:LDAPPASS:"
-    client-secret: "_env:AZURECLIENTSECRET:''"
+    baseDN:  "_env:LDAPBASE:"
-    tenant-id:     "_env:AZURETENANTID:00000000-0000-0000-0000-000000000000"
+    scope:   "_env:LDAPSCOPE:WholeSubtree"
-    scopes:        "_env:AZURESCOPES:[email,openid,profile,offline_access]"
+    timeout: "_env:LDAPTIMEOUT:5"
-    # protocol: "ldap"
+    search-timeout: "_env:LDAPSEARCHTIME:5"
-    # config:
+    pool:
-    #   host:           "_env:LDAPHOST:"
+      stripes: "_env:LDAPSTRIPES:1"
-    #   tls:            "_env:LDAPTLS:"
+      timeout: "_env:LDAPTIMEOUT:20"
-    #   port:           "_env:LDAPPORT:389"
+      limit:   "_env:LDAPLIMIT:10"
-    #   user:           "_env:LDAPUSER:"
-    #   pass:           "_env:LDAPPASS:"
-    #   baseDN:         "_env:LDAPBASE:"
-    #   scope:          "_env:LDAPSCOPE:WholeSubtree"
-    #   timeout:        "_env:LDAPTIMEOUT:5"
-    #   search-timeout: "_env:LDAPSEARCHTIME:5"
 
-single-sign-on: "_env:OIDC_SSO:false"
+ldap-re-test-failover: 60
-
-# Automatically redirect to SSO route when not signed on
-# Note: This will force authentication, thus the site will be inaccessible without external credentials. Only use this option when it is ensured that every user that should be able to access the site has valid external credentials!
-auto-sign-on: "_env:AUTO_SIGN_ON:false"
-
-# TODO: generalize for arbitrary auth protocols
-# TODO: maybe use separate pools for external databases?
-ldap-pool:
-  stripes: "_env:LDAPSTRIPES:1"
-  timeout: "_env:LDAPTIMEOUT:20"
-  limit:   "_env:LDAPLIMIT:10"
-
-# TODO: reintroduce and move into failover settings once failover mode has been reimplemented
-# user-retest-failover: 60
-# TODO; maybe implement syncWithin and syncInterval per auth source
-user-sync-within:   "_env:USER_SYNC_WITHIN:1209600" # 14 Tage in Sekunden
-user-sync-interval: "_env:USER_SYNC_INTERVAL:3600"  # jede Stunde
 
 lms-direct:
   upload-header:        "_env:LMSUPLOADHEADER:true"
@@ -177,10 +158,12 @@ lms-direct:
   deletion-days:        "_env:LMSDELETIONDAYS:7"
 
 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:"
+  pass:         "_env:AVSPASS:\"0000\""
+  timeout:      "_env:AVSTIMEOUT:42"
+  cache-expiry: "_env:AVSCACHEEXPIRY:420"
 
 lpr:
   host:    "_env:LPRHOST:fravm017173.fra.fraport.de"
@@ -296,8 +279,8 @@ user-defaults:
   max-favourites:      0
   max-favourite-terms: 2
   theme:               Default
-  date-time-format:    "%d %b %y %R"
+  date-time-format:    "%d.%m.%Y %R"
-  date-format:         "%d %b %Y"
+  date-format:         "%d.%m.%y"
   time-format:         "%R"
   download-files:      false
   warning-days:        1209600

fixtest.sh

@@ -0,0 +1,6 @@
+if [[ ! -d .stack-work-test ]]; then
+    mv -vT .stack-work .stack-work-test
+    [[ -d .stack-work-build ]] && mv -vT .stack-work-build .stack-work
+else
+    echo "Directory .stack-work-test exists already."
+fi

flake.lock

@@ -25,12 +25,12 @@
         "rev": "40393c938111ac78232dc2c7eec5edb4a22d03e8",
         "revCount": 62,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git"
       }
     },
     "cabal-32": {
@@ -92,12 +92,12 @@
         "rev": "f8170266ab25b533576e96715bedffc5aa4f19fa",
         "revCount": 153,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/colonnade.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/colonnade.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git"
       }
     },
     "conduit-resumablesink": {
@@ -109,12 +109,12 @@
         "rev": "cbea6159c2975d42f948525e03e12fc390da53c5",
         "revCount": 10,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/conduit-resumablesink.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/conduit-resumablesink.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git"
       }
     },
     "cryptoids": {
@@ -126,29 +126,29 @@
         "rev": "130b0dcbf2b09ccdf387b50262f1efbbbf1819e3",
         "revCount": 44,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/cryptoids.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/cryptoids.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git"
       }
     },
     "cryptonite": {
       "flake": false,
       "locked": {
-        "lastModified": 1704764911,
+        "lastModified": 1624444174,
-        "narHash": "sha256-VuEWT2Bd4aSJyRcXpB+lsGDqxrTHB/uRvILzYWLNfxk=",
+        "narHash": "sha256-sDMA4ej1NIModAt7PQvcgIknI3KwfzcAp9YQUSe4CWw=",
         "ref": "uni2work",
-        "rev": "f78fca2504bb767d632a3bac8dbbc23367eff0e9",
+        "rev": "71a630edaf5f22c464e24fac8d9d310f4055ea1f",
-        "revCount": 1220,
+        "revCount": 1202,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/cryptonite.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/cryptonite.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git"
       }
     },
     "encoding": {
@@ -160,12 +160,12 @@
         "rev": "22fc3bb14841d8d50997aa47f1be3852e666f787",
         "revCount": 162,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/encoding.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/encoding.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git"
       }
     },
     "esqueleto": {
@@ -177,12 +177,12 @@
         "rev": "e18dd125c5ea26fa4e88bed079b61d8c1365ee37",
         "revCount": 708,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/esqueleto.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/esqueleto.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git"
       }
     },
     "flake-utils": {
@@ -310,12 +310,12 @@
         "rev": "01afaf599ba6f8a9d804c269e91d3190b249d3f0",
         "revCount": 61,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/ldap-client.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/ldap-client.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git"
       }
     },
     "memcached-binary": {
@@ -327,29 +327,29 @@
         "rev": "b7071df50bad3a251a544b984e4bf98fa09b8fae",
         "revCount": 28,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/memcached-binary.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/memcached-binary.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git"
       }
     },
     "minio-hs": {
       "flake": false,
       "locked": {
-        "lastModified": 1711841413,
+        "lastModified": 1597069863,
-        "narHash": "sha256-9IdjU1/Mzi4ZGhX7tFJhqliratSVRvDwe9AesD0lkt8=",
+        "narHash": "sha256-JmMajaLT4+zt+w2koDkaloFL8ugmrQBlcYKj+78qn9M=",
         "ref": "uni2work",
-        "rev": "cb25dd23c4cf62a956caad722d45ad6cf3cc5e3a",
+        "rev": "42103ab247057c04c8ce7a83d9d4c160713a3df1",
-        "revCount": 224,
+        "revCount": 197,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/minio-hs.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/minio-hs.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git"
       }
     },
     "nix-tools": {
@@ -516,7 +516,6 @@
         "serversession": "serversession",
         "xss-sanitize": "xss-sanitize",
         "yesod": "yesod",
-        "yesod-auth-oauth2": "yesod-auth-oauth2",
         "zip-stream": "zip-stream"
       }
     },
@@ -529,12 +528,12 @@
         "rev": "b9d76def10da1260c7f6aa82bda32111f37a952b",
         "revCount": 174,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/serversession.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/serversession.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git"
       }
     },
     "stackage": {
@@ -577,46 +576,29 @@
         "rev": "dc928c3a456074b8777603bea20e81937321777f",
         "revCount": 114,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/xss-sanitize.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/xss-sanitize.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git"
       }
     },
     "yesod": {
       "flake": false,
       "locked": {
-        "lastModified": 1705542497,
+        "lastModified": 1625061191,
-        "narHash": "sha256-DYri6G3LeL3Gu11K0gAcUOxMwyKrLVkNnb5oTjHKRro=",
+        "narHash": "sha256-K0X2MwUStChml1DlJ7t4yBMDwrMe6j/780nJtSy9Hss=",
         "ref": "uni2work",
-        "rev": "9f8d26371d4760f8985e7bbe00c3ac16be1301bc",
+        "rev": "a59f63e0336ee61f7a90b8778e9147305d3127bb",
-        "revCount": 5208,
+        "revCount": 5053,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/yesod.git?commit=aa671eb41fdad360f2f7cb844f8de03479efe3f7"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/yesod.git?commit=aa671eb41fdad360f2f7cb844f8de03479efe3f7"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git"
-      }
-    },
-    "yesod-auth-oauth2": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1717297679,
-        "narHash": "sha256-IhPGedmDNoN1lJDHTjgZk2LC0WAmQ1D9bB6su3pgt0U=",
-        "ref": "ghc-8.10.4",
-        "rev": "da676b530887306b645d0170f82e7dd0611d9601",
-        "revCount": 423,
-        "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/yesod-auth-oauth2.git?commit=da676b530887306b645d0170f82e7dd0611d9601"
-      },
-      "original": {
-        "ref": "ghc-8.10.4",
-        "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/yesod-auth-oauth2.git?commit=da676b530887306b645d0170f82e7dd0611d9601"
       }
     },
     "zip-stream": {
@@ -628,12 +610,12 @@
         "rev": "843683d024f767de236f74d24a3348f69181a720",
         "revCount": 39,
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/zip-stream.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git"
       },
       "original": {
         "ref": "uni2work",
         "type": "git",
-        "url": "https://gitlab.uniworx.de/haskell/zip-stream.git"
+        "url": "https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git"
       }
     }
   },

flake.nix

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor@kleen.consulting>
+# SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor@kleen.consulting>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -29,63 +29,59 @@
     };
 
     encoding = {
-      url = "git+https://gitlab.uniworx.de/haskell/encoding.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git?ref=uni2work";
       flake = false;
     };
     memcached-binary = {
-      url = "git+https://gitlab.uniworx.de/haskell/memcached-binary.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git?ref=uni2work";
       flake = false;
     };
     conduit-resumablesink = {
-      url = "git+https://gitlab.uniworx.de/haskell/conduit-resumablesink.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git?ref=uni2work";
       flake = false;
     };
     HaskellNet-SSL = {
-      url = "git+https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git?ref=uni2work";
       flake = false;
     };
     ldap-client = {
-      url = "git+https://gitlab.uniworx.de/haskell/ldap-client.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git?ref=uni2work";
       flake = false;
     };
     serversession = {
-      url = "git+https://gitlab.uniworx.de/haskell/serversession.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git?ref=uni2work";
       flake = false;
     };
     xss-sanitize = {
-      url = "git+https://gitlab.uniworx.de/haskell/xss-sanitize.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git?ref=uni2work";
       flake = false;
     };
     colonnade = {
-      url = "git+https://gitlab.uniworx.de/haskell/colonnade.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git?ref=uni2work";
       flake = false;
     };
     minio-hs = {
-      url = "git+https://gitlab.uniworx.de/haskell/minio-hs.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git?ref=uni2work";
       flake = false;
     };
     cryptoids = {
-      url = "git+https://gitlab.uniworx.de/haskell/cryptoids.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git?ref=uni2work";
       flake = false;
     };
     zip-stream = {
-      url = "git+https://gitlab.uniworx.de/haskell/zip-stream.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git?ref=uni2work";
       flake = false;
     };
     yesod = {
-      url = "git+https://gitlab.uniworx.de/haskell/yesod.git?ref=uni2work&commit=aa671eb41fdad360f2f7cb844f8de03479efe3f7";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git?ref=uni2work";
-      flake = false;
-    };
-    yesod-auth-oauth2 = {
-      url = "git+https://gitlab.uniworx.de/haskell/yesod-auth-oauth2.git?ref=ghc-8.10.4&commit=da676b530887306b645d0170f82e7dd0611d9601";
       flake = false;
     };
     cryptonite = {
-      url = "git+https://gitlab.uniworx.de/haskell/cryptonite.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git?ref=uni2work";
       flake = false;
     };
     esqueleto = {
-      url = "git+https://gitlab.uniworx.de/haskell/esqueleto.git?ref=uni2work";
+      url = "git+https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git?ref=uni2work";
       flake = false;
     };
   };

frontend/src/_common.sass

@@ -3,11 +3,11 @@
 // SPDX-License-Identifier: AGPL-3.0-or-later
 // SPDX-License-Identifier: LicenseRef-Fraport-Corporate-Design
 
-// @use "~@fortawesome/fontawesome-pro/scss/fontawesome" with ( $fa-font-path: "~@fortawesome/fontawesome-pro/webfonts" )
+@use "~@fortawesome/fontawesome-pro/scss/fontawesome" with ( $fa-font-path: "~@fortawesome/fontawesome-pro/webfonts" )
-// 
+
-// @forward "~@fortawesome/fontawesome-pro/scss/fontawesome"
+@forward "~@fortawesome/fontawesome-pro/scss/fontawesome"
-// 
+
-// @use "~@fortawesome/fontawesome-pro/scss/solid"
+@use "~@fortawesome/fontawesome-pro/scss/solid"
 
 @use "~typeface-roboto" as roboto
 @use "~typeface-source-sans-pro" as source-sans-pro

frontend/src/app.sass

@@ -450,9 +450,9 @@ input[type="button"].btn-info:not(.btn-link):hover,
       color: inherit
 
     &::before
-      // @extend .fas
+      @extend .fas
 
-      // content: fa-content($fa-var-link)
+      content: fa-content($fa-var-link)
       margin-right: 0.25em
 
     &.table__th-link::before
@@ -655,7 +655,7 @@ section
     margin: 0 auto 0.5rem
 
   &::before
-    // @extend .fas
+    @extend .fas
 
     position: absolute
     display: flex

frontend/src/utils/alerts/alerts.sass

@@ -24,9 +24,9 @@
   cursor: pointer
 
   &::before
-    // @extend .fas
+    @extend .fas
 
-    // content: fa-content($fa-var-chevron-up)
+    content: fa-content($fa-var-chevron-up)
     position: absolute
     left: 50%
     top: 0
@@ -152,9 +152,9 @@
       color: white
 
   &::before
-    // @extend .fas
+    @extend .fas
 
-    // content: fa-content($fa-var-times)
+    content: fa-content($fa-var-times)
     position: absolute
     top: 50%
     left: 50%

frontend/src/utils/exam-correct/exam-correct.js

@@ -301,7 +301,7 @@ export class ExamCorrect {
       users: [user],
       status: STATUS.LOADING,
     };
-    if (results && results !== {}) rowInfo.results = results;
+    if (results && Object.keys(results).length > 0) rowInfo.results = results;
     if (result !== undefined) rowInfo.result = result;
     this._addRow(rowInfo);
 

frontend/src/utils/modal/modal.sass

@@ -98,9 +98,9 @@ div.modal__trigger
   z-index: 20
 
   &::before
-    // @extend .fas
+    @extend .fas
 
-    // content: fa-content($fa-var-times)
+    content: fa-content($fa-var-times)
     color: white
 
 .modal__content

frontend/src/utils/tooltips/tooltips.sass

@@ -123,8 +123,8 @@
   padding: 4px 17px 4px 4px
 
   &::after
-    // @extend .fas
+    @extend .fas
-    // @extend .fa-fw
+    @extend .fa-fw
 
     content: '\f129'
     position: absolute

is-clean.sh

@@ -16,13 +16,8 @@ fi
 branch="$(git rev-parse --abbrev-ref HEAD)"
 
 if [[ $branch != "master" && $branch != "test" ]]; then
-  if echo $@ | grep -xqe '--dev';
-  then
-    : # dev-releases possible on any branch
-  else
     echo "Not on master or test" >&2
     exit 1
-  fi
 fi
 
 ourHash=$(git rev-parse HEAD)

messages/uniworx/categories/admin/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -67,6 +67,7 @@ BearerTokenExpiresTip: Wird der Ablaufzeitpunkt überschrieben und kein Ablaufze
 BearerTokenOverrideStart: Startzeitpunkt
 BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwendung des Tokens nur der Ablaufzeitpunkt überprüft.
 HeadingAdminTokens: Tokens ausstellen
+UserUnknown: Unbekannter Benutzer:in
 
 #templates adminFeautures
 StudyFeaturesDegrees: Abschlüsse
@@ -101,7 +102,7 @@ ProblemsHeadingDrivers: Fahrberechtigungen
 ProblemsHeadingNotifications: Benachrichtigungen
 ProblemsHeadingMisc: Allgemein
 ProblemsAvsProblem: Synchronisation mit AVS/MoBaKo komplett fehlgeschlagen
-ProblemsDriverSynch n@Int: #{tshow n} Diskrepanzen zwischen AVS und FRADrive
+ProblemsDriverSynch n@Int: #{n} #{pluralDE n "Diskrepanz" "Diskrepanzen"} zwischen AVS und FRADrive
 ProblemsDriverSynch0: Alle Sperrungen von Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen
 ProblemsDriverSynch1down: Alle Sperrungen von Rollfeld-Fahrberechtigungen 'R' sind im AVS eingetragen
 ProblemsDriverSynch1up: Alle gültigen Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen
@@ -109,10 +110,11 @@ ProblemsDriverSynch2: Alle gültigen Rollfeld-Fahrberechtigungen 'R' sind im AVS
 ProblemsRDriversHaveFs: Alle Inhaber einer Rollfeld-Fahrberechtigung besitzen auch eine gültige Vorfeld-Fahrberechtigung
 ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS Identifikationsnummer zugeordnet werden
 ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt 
-ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge der vergangenen #{show n} Tage wurden von der Druckerei bestätigt
+ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge #{pluralDE n "des vergangenen Tages" ("der vergangenen "<> tshow n <> " Tage")} wurden von der Druckerei bestätigt
 ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig
 ProblemsUnreachableHeading: Unerreichbare Benutzer
 ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können:
+ProblemsUnreachableButtons: Synchronisation für Unerreichbare starten
 ProblemsRWithoutFHeading: Fahrer mit R ohne F
 ProblemsRWithoutFBody: Diese Fahrer sind wegen einer ungültigen Vorfeld-Fahrberechtigung komplett gesperrt, obwohl eine gültige Rollfeld-Fahrberechtigung besteht:
 ProblemsNoAvsIdHeading: Fahrer ohne AVS-Id
@@ -120,6 +122,24 @@ ProblemsNoAvsIdBody: Fahrer mit gültiger Fahrberechtigung in FRADrive, welche t
 ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen
 ProblemsAvsErrorHeading: Fehlermeldungen
 ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit 
+ProblemAvsUsrHadR: Momentan gültiges R im AVS
+
+AdminProblemSolved: Erledigt
+AdminProblemSolver: Bearbeitet von
+AdminProblemCreated: Erkannt
+AdminProblemInfo: Problembeschreibung
+AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Problem"} als erledigt markiert
+AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet
+AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
+AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma 
+AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma 
+AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzter.
+AdminProblemCompanySuperiorNotFound t@Text: Neuer unbekannter firmenweiter Vorgesetzter mit E-Mail #{t}, keine Ansprechpartnerbeziehungen eingerichtet.
+AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzter: 
+AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma 
+AdminProblemUser: Betroffener
+ProblemTableMarkSolved: Als erledigt markieren
+ProblemTableMarkUnsolved: Erledigt Markierung löschen
 
 InterfacesOk: Schnittstellen sind ok.
 InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}!
@@ -128,8 +148,15 @@ InterfaceName: Schnittstelle
 InterfaceLastSynch: Zuletzt
 InterfaceSubtype: Betreffend
 InterfaceWrite: Schreibend
-
-AdminUserPassword: Passwort
 InterfaceSuccess: Rückmeldung
 InterfaceInfo: Nachricht
-InterfaceFreshness: Prüfungszeitraum (h)
+InterfaceFreshness: Maximale Zugriffsfrist
+InterfaceFreshnessTooltip: Zeitspanne innerhalb der ein erneuter erfolgreicher Schnittstellenzugriff erfolgen muss, ohne Warnungen auszulösen
+ConfigInterfacesHeading: Konfiguration Zugriffsfristen
+
+IWTActAdd: Hinzufügen/Ändern
+IWTActDelete: Entfernen
+InterfaceWarningAdded: Schnittstellenwarnungszeit hinzugefügt oder geändert
+InterfaceWarningDeleted n@Int: #{pluralDEeN n "Schnittstellenwarnungszeit"} gelöscht
+InterfaceWarningDisabledEntirely: Alle Fehler ignorieren
+InterfaceWarningDisabledInterval: Keine Zugriffsfrist

messages/uniworx/categories/admin/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -18,10 +18,10 @@ NoNameCandidatesInferred: No new name-mappings inferred
 AllNameIncidencesDeleted: Successfully deleted all name observations
 AllParentIncidencesDeleted: Successfully deleted all parent-relation observations
 AllStandaloneIncidencesDeleted: Successfully deleted all standalone observations
-IncidencesDeleted n: Successfully deleted #{show n} #{pluralEN n "observation" "observations"}
+IncidencesDeleted n: Successfully deleted #{pluralENsN n "observation"}
-RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "parent-candidate" "parent-candidates"}
+RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralENs n "parent-candidate"}
-RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "standalone-candidate" "standalone-candidates"}
+RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralENs n "standalone-candidate"}
-ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "parent-relation" "parent-reliations"}
+ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralENs n "parent-relation"}
 NoParentCandidatesInferred: No new parent-relations inferred
 StudyDegreeChangeSuccess: Successfully updated degrees
 StudyTermsShort: Field shorthand
@@ -67,6 +67,7 @@ BearerTokenExpiresTip: If no expiration time is given, the token will not expire
 BearerTokenOverrideStart: Start time
 BearerTokenOverrideStartTip: If no start time is given, only the expiration time will be checked when the token is used.
 HeadingAdminTokens: Issue tokens
+UserUnknown: User unknown
 
 #templates adminfeatures
 StudyFeaturesDegrees: Degrees
@@ -101,7 +102,7 @@ ProblemsHeadingDrivers: Driving Licences
 ProblemsHeadingNotifications: User communication
 ProblemsHeadingMisc: Miscellaneous
 ProblemsAvsProblem: Synchronisation with AVS/MoBaKo failed entirely
-ProblemsDriverSynch n: #{tshow n} mismatches between AVS and FRADrive
+ProblemsDriverSynch n: #{tshow n} #{pluralEN n "mismatch" "mismatches"} between AVS and FRADrive
 ProblemsDriverSynch0: All revocations of apron driving licences 'F' were successfully registered with AVS
 ProblemsDriverSynch1down: All revocations of maneuvering area driving licences 'R' were successfully registered with AVS
 ProblemsDriverSynch1up: All valid apron driving licences 'F' were successfully registered with AVS
@@ -109,10 +110,11 @@ ProblemsDriverSynch2: All valid maneuvering area driving licences 'R' were succe
 ProblemsRDriversHaveFs: All driving licence 'R' holders also have a valid 'F' licence
 ProblemsDriversHaveAvsIds: All driving licence holder could be matched with their AVS id
 ProblemsUsersAreReachable: Either Email or postal address is known for all users
-ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{show n} days were acknowledged as printed by the airport printing center
+ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{pluralENsN n "day"} were acknowledged as printed by the airport printing center
 ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit
 ProblemsUnreachableHeading: Unreachable Users
 ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications:
+ProblemsUnreachableButtons: Start synchronisation for unreachable users only
 ProblemsRWithoutFHeading: Drivers having 'R' but not 'F'
 ProblemsRWithoutFBody: Drivers without apron driving licence are prohibited from driving, even if they own a valid maneuvering driving licence:
 ProblemsNoAvsIdHeading: Drivers without AVS id
@@ -120,6 +122,24 @@ ProblemsNoAvsIdBody: Drivers having a valid apron driving licence within FRADriv
 ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences
 ProblemsAvsErrorHeading: Error Log
 ProblemsInterfaceSince: Only considering successes and errors since
+ProblemAvsUsrHadR: Currenlt R valid in AVS
+
+AdminProblemSolved: Done
+AdminProblemSolver: Solved by
+AdminProblemCreated: Recognized
+AdminProblemInfo: Problem
+AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved
+AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened
+AdminProblemNewCompany: New company from AVS; verify and add default supervisors
+AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company 
+AdminProblemSupervisorLeftCompany b: Only default company supervisor #{boolText mempty "with reroute" b} for this user changed to new company 
+AdminProblemCompanySuperiorChange: New company wide superior.
+AdminProblemCompanySuperiorNotFound t: Unable to set supervision for new unknown company wide superior having Email #{t}.
+AdminProblemCompanySuperiorPrevious: Previous superior: 
+AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company
+AdminProblemUser: Affected
+ProblemTableMarkSolved: Mark done
+ProblemTableMarkUnsolved: Reopen as undone
 
 InterfacesOk: Interfaces are ok.
 InterfacesFail n: #{pluralENsN n "interface problem"}!
@@ -128,8 +148,15 @@ InterfaceName: Interface
 InterfaceLastSynch: Last
 InterfaceSubtype: Affecting
 InterfaceWrite: Write
-
-AdminUserPassword: Password
 InterfaceSuccess: Returned
 InterfaceInfo: Message
-InterfaceFreshness: Check hours
+InterfaceFreshness: Maximum usage period
+InterfaceFreshnessTooltip: Time period within which the next successful interface access must occur to avoid a warning
+ConfigInterfacesHeading: Configure interface usage warnings
+
+IWTActAdd: Add/Edit
+IWTActDelete: Delete
+InterfaceWarningAdded: Interface warning time added/changed
+InterfaceWarningDeleted n: #{pluralENsN n "interface warning time"} deleted
+InterfaceWarningDisabledEntirely: Ignore all errors
+InterfaceWarningDisabledInterval: No maximum usage period

messages/uniworx/categories/authorization/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 David Mosbach <david.mosbach@uniworx.de>, 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>, Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -72,8 +72,8 @@ UnauthorizedTutorialTutorControl: Ausbilder:innen dürfen diesen Kurs nicht edit
 UnauthorizedCourseTutor: Sie sind nicht Ausbilder:in für diese Kursart.
 UnauthorizedTutor: Sie sind nicht Ausbilder:in.
 UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Kurs mit derselben Registrierungs-Gruppe eingetragen.
-UnauthorizedExternal: Angegebene:r Benuzter:in meldet sich nicht über einen aktuell unterstützten externen Login an.
+UnauthorizedLDAP: Angegebener Nutzer/Angegebene Nutzerin meldet sich nicht mit Fraport Login an.
-UnauthorizedInternal: Angegebene:r Benutzer:in meldet sich nicht mit FRADrive-Kennung an.
+UnauthorizedPWHash: Angegebener Nutzer/Angegebene Nutzerin meldet sich nicht mit FRADrive-Kennung an.
 UnauthorizedExternalExamListNotEmpty: Liste von externen Prüfungen ist nicht leer
 UnauthorizedExternalExamLecturer: Sie sind nicht als Prüfer:in für diese externe Prüfung eingetragen
 UnauthorizedSubmissionSubmissionGroup: Sie sind nicht Mitglied in einer der registrierten Abgabegruppen, die an dieser Abgabe beteiligt sind
@@ -102,15 +102,15 @@ LDAPLoginTitle: Fraport Login für interne und externe Nutzer
 PWHashLoginTitle: Spezieller Funktionsnutzer Login
 PWHashLoginNote: Verwenden Sie dieses Formular nur, wenn Sie explizit dazu aufgefordert wurden. Alle anderen sollten das andere Login Formular verwenden!
 DummyLoginTitle: Development-Login
-InternalLoginError: Interner Fehler beim Login
+InternalLdapError: Interner Fehler beim Fraport Büko-Login
-DecodeUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln
+CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln
-DecodeUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln
+CampusUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln
-DecodeUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
+CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
-DecodeUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln
+CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln
-DecodeUserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln
+CampusUserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln
-DecodeUserInvalidTitle: Konnte anhand des Fraport Büko-Logins keinen akademischen Titel ermitteln
+CampusUserInvalidTitle: Konnte anhand des Fraport Büko-Logins keinen akademischen Titel ermitteln
-DecodeUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Studiengänge ermitteln
+CampusUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Studiengänge ermitteln
-DecodeUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Bereiche ermitteln
+CampusUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Bereiche ermitteln
 InvalidCredentialsADNoSuchObject: Benutzereintrag existiert nicht
 InvalidCredentialsADLogonFailure: Ungültiges Passwort
 InvalidCredentialsADAccountRestriction: Beschränkungen des Fraport Accounts verhindern Login
@@ -139,6 +139,3 @@ FormHoneypotNamePlaceholder: Name
 FormHoneypotComment: Kommentar
 FormHoneypotCommentPlaceholder: Kommentar
 FormHoneypotFilled: Bitte füllen Sie keines der verstecken Felder aus
-
-Logout: Abmeldung
-SingleSignOut: Abmeldung bei Azure

messages/uniworx/categories/authorization/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -72,8 +72,8 @@ UnauthorizedTutorialTutorControl: Instructors may not edit this course.
 UnauthorizedCourseTutor: You are no instructor for this course.
 UnauthorizedTutor: You are no instructor.
 UnauthorizedTutorialRegisterGroup: You are already registered for a course with the same registration group.
-UnauthorizedExternal: Specified user does not log in with any currently supported external login.
+UnauthorizedLDAP: Specified user does not log in with their Fraport password.
-UnauthorizedInternal: Specified user does not log in with a FRADrive-account.
+UnauthorizedPWHash: Specified user does not log in with an FRADrive-account.
 UnauthorizedExternalExamListNotEmpty: List of external exams is not empty
 UnauthorizedExternalExamLecturer: You are not an associated person for this external exam
 UnauthorizedSubmissionSubmissionGroup: You are not member in any of the submission groups for this submission
@@ -103,15 +103,15 @@ LDAPLoginTitle: Fraport login for intern and extern users
 PWHashLoginTitle: Special function user login
 PWHashLoginNote: Only use this login form if you have received special instructions to do so. All others should use the other login field.
 DummyLoginTitle: Development login
-InternalLoginError: Internal error during login
+InternalLdapError: Internal error during Fraport Büko login
-DecodeUserInvalidIdent: Could not determine unique identification during Fraport Büko login
+CampusUserInvalidIdent: Could not determine unique identification during Fraport Büko login
-DecodeUserInvalidEmail: Could not determine email address during Fraport Büko login
+CampusUserInvalidEmail: Could not determine email address during Fraport Büko login
-DecodeUserInvalidDisplayName: Could not determine display name during Fraport Büko login
+CampusUserInvalidDisplayName: Could not determine display name during Fraport Büko login
-DecodeUserInvalidGivenName: Could not determine given name during Fraport Büko login
+CampusUserInvalidGivenName: Could not determine given name during Fraport Büko login
-DecodeUserInvalidSurname: Could not determine surname during Fraport Büko login
+CampusUserInvalidSurname: Could not determine surname during Fraport Büko login
-DecodeUserInvalidTitle: Could not determine title during Fraport Büko login
+CampusUserInvalidTitle: Could not determine title during Fraport Büko login
-DecodeUserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login
+CampusUserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login
-DecodeUserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login
+CampusUserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login
 InvalidCredentialsADNoSuchObject: User entry does not exist
 InvalidCredentialsADLogonFailure: Invalid password
 InvalidCredentialsADAccountRestriction: Restrictions on your Fraport account prevent a login
@@ -140,6 +140,3 @@ FormHoneypotNamePlaceholder !ident-ok: Name
 FormHoneypotComment: Comment
 FormHoneypotCommentPlaceholder: Comment
 FormHoneypotFilled: Please do not fill in any of the hidden fields
-
-Logout: Logout
-SingleSignOut: Azure logout

messages/uniworx/categories/avs/de-de-formal.msg

@@ -4,15 +4,19 @@
 AvsPersonInfo: AVS Personendaten
 AvsPersonId: AVS Personen Id
 AvsPersonNo: AVS Personennummer
+AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
+AvsPersonNoMismatch: AVS Personennummer hat sich geändert und wurde in FRADrive noch nicht aktualisiert
+AvsPersonNoDiffers: Es sind derzeit zwei verschiedene AVS Personennummern zugeordnet. Bitte einen Administrator kontaktieren.
 AvsCardNo: Ausweiskartennummer 
 AvsFirstName: Vorname
 AvsLastName: Nachname
+AvsPrimaryCompany: Primäre Firma
 AvsInternalPersonalNo: Personalnummer (nur Fraport AG)
 AvsVersionNo: Versionsnummer
+AvsQueryNeeded: Benötigt Verbindung zum AVS.
 AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
 AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
 AvsLicence: Fahrberechtigung
-AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
 AvsTitleLicenceSynch: Abgleich Fahrberechtigungen zwischen AVS und FRADrive
 BtnAvsRevokeUnknown: Fahrberechtigungen im AVS sofort entziehen
 BtnAvsImportUnknown: AVS Daten unbekannter Personen importieren
@@ -27,13 +31,33 @@ RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} in FRADrive entzogen für
 RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt
 RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details
 AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.
+AvsCommunicationTimeout: AVS Schnittstelle antwortete nicht.
 LicenceTableChangeAvs: Im AVS ändern
 LicenceTableGrantFDrive: In FRADrive erteilen
 LicenceTableRevokeFDrive: In FRADrive entziehen
 TableAvsActiveCards: Gültige Ausweise
+TableAvsCardValid: Aktuell gültig
+TableAvsCardIssueDate: Ausgestellt am
+TableAvsCardValidTo: Gültig bis
+AvsCardAreas: Ausweiszusätze
+AvsCardColor: Ausweisfarbe
 AvsCardColorGreen: Grün
 AvsCardColorBlue: Blau
 AvsCardColorRed: Rot
 AvsCardColorYellow: Gelb
 LastAvsSynchronisation: Letzte AVS-Synchronisation
+LastAvsSyncedBefore: Letzte AVS-Synchronisation vor
 LastAvsSynchError: Letzte AVS-Fehlermeldung
+
+AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwortet nicht
+AvsUserUnassociated user@UserDisplayName: AVS Id unbekannt für Nutzer #{user}
+AvsUserUnknownByAvs api@AvsPersonId: AVS kennt Id #{tshow api} nicht (mehr)
+AvsUserAmbiguous api@AvsPersonId: AVS Id #{tshow api} ist nicht eindeutig
+AvsStatusSearchEmpty: AVS lieferte keine Ausweisinformationen
+AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis
+AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse
+AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason}
+AvsIdMismatch api1@AvsPersonId api2@AvsPersonId: AVS Suche für Id #{tshow api1} lieferte stattdessen Id #{tshow api2}
+AvsUserCreationFailed api@AvsPersonId: Für AVS Id #{tshow api} konnte kein neuer Benutzer angelegt werden, da es eine gemeinsame Id (z.B. Personalnummer) mit einem existierenden, aber verschiedenen Nutzer gibt.
+AvsCardsEmpty: AVS Suche lieferte keinerlei Ausweiskarten
+AvsCurrentData: Alle angezeigte Daten wurden kürzlich direkt über die AVS Schnittstelle abgerufen.

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

@@ -1,18 +1,23 @@
 # SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
-AvsPersonInfo: AVS Person Info
+AvsPersonInfo: AVS person info
-AvsPersonId: AVS Person Id
+AvsPersonId: AVS person id
-AvsPersonNo: AVS Person Number
+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
-AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
+
 AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive
 BtnAvsRevokeUnknown: Revoke AVS driving licences for unknown persons immediately
 BtnAvsImportUnknown: Import AVS data for unknown persons
@@ -27,13 +32,33 @@ RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} revoked in FRADrive for #{
 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.

messages/uniworx/categories/courses/courses/de-de-formal.msg

@@ -70,6 +70,10 @@ CourseInvalidInput: Eingaben bitte korrigieren.
 CourseEditTitle: Kursart editieren/anlegen
 CourseEditOk       tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert.
 CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen andere Kursart mit dem selben Kürzel oder Titel in diesem Jahr und Bereich.
+CourseEditQualificationFail: Eine Qualifikation konnte uas unbekanntem Grund nicht mit diesem Kurs assoziert werden.
+CourseEditQualificationFailRights qsh@QualificationShorthand ssh@SchoolId: Qualifikation #{qsh} konnte nicht mit diesem Kurs assoziert werden, da Ihre Berechtigungen für Bereich #{ssh} dazu nicht ausreichen.
+CourseEditQualificationFailExists: Diese Qualifikation ist bereits assoziert
+CourseEditQualificationFailOrder: Diese Sortierpriorität existiert bereits
 CourseLecturer: Kursverwalter:in
 MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursartteilnahme
 CourseParticipantInviteHeading courseName@Text: Einladung zum Kursartteilnahmer für #{courseName}

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

@@ -70,8 +70,12 @@ CourseInvalidInput: Invalid input
 CourseEditTitle: Edit/Create course
 CourseEditOk tid ssh csh: Successfully edited course type #{tid}-#{ssh}-#{csh} 
 CourseEditDupShort tid ssh csh: Could not edit course type #{tid}-#{ssh}-#{csh}. Another course type with the same shorthand or title already exists for the given year and school.
+CourseEditQualificationFail: A qualifikation could not be associated with this course for unknown reasons.
+CourseEditQualificationFailRights qsh ssh: Qualification #{qsh} could not be associated with this course, due to your insufficient rights for department #{ssh}.
+CourseEditQualificationFailExists: This qualification is already associated
+CourseEditQualificationFailOrder: This sort order priority is used already
 CourseLecturer: Course administrator
-MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course
+MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course
 CourseParticipantInviteHeading courseName: Invitation to enrol for #{courseName}
 CourseParticipantInviteExplanation: You were invited to be a participant of a course.
 CourseParticipantInviteField: Email addresses to invite

messages/uniworx/categories/firm/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
+# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -7,7 +7,6 @@ FirmSuperForeign: Firmenfremde Ansprechpartner
 FirmSuperIrregular: Irreguläre Ansprechpartner
 FirmAssociates: Firmenangehörige
 FirmContact: Firmenkontakt
-FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt.
 FirmEmail: Allgemeine Email
 FirmAddress: Postanschrift
 FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige
@@ -16,11 +15,15 @@ FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht.
 FirmActNotify: Mitteilung versenden
 FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
 FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
+FirmActRemoveSupers: Alle rein firmenbezogenen Ansprechpartnerbeziehungen für diese Personen entfernen?
 FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
-FirmActAddSupersvisors: Ansprechpartner hinzufügen
+FirmActResetSupersKeepAll: Alle behalten
+FirmActResetSupersRemoveAps: Nur Standardansprechpartner entfernen
+FirmActResetSupersRemoveAll: Alle entfernen
+FirmActAddSupervisors: Ansprechpartner hinzufügen
 FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
 FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
-RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
+RemoveSupervisors ndef@Int64: #{ndef} Standardansprechpartner entfernt. 
 FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
 FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
 FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.
@@ -28,17 +31,23 @@ FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft n
 FirmUserActNotify: Mitteilung versenden
 FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen
 FirmUserActSetSupervisor: Ansprechpartner ändern
+FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
+FirmUserActChangeDetails: Firmenassoziation bearbeiten
+FirmUserActRemove: Firmenassoziation entfernen
+FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
+FirmUserActChangeDetailsResult n@Int64 t@Int64: Firmenassoziation von #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden aktualisiert
+FirmUserActChangeResult n@Int64 t@Int64: Benachrichtigungseinstellung für #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden geändert
+FirmUserActRemoveResult uc@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt. 
+FirmRemoveSupervision sup@Int64 sub@Int64: #{noneMoreDE sup "" (tshow sup <> " Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöscht. ")} #{noneOneMoreDE sub "Keine Ansprechpartnerbeziehung" "Eine Ansprechpartnerbeziehung" (tshow sup <> " Ansprechpartnerbeziehungen")} wegen entferntem Angesprochenem gelöscht.
 FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen
 FirmSetSupervisor: Existierende Ansprechpartner hinzufügen
 FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)}
-FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
-FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
 FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)}
 FirmSuperActNotify: Mitteilung versenden
 FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern
 FirmSuperActSwitchSuperInfo: Betrifft keine firmenfremden Ansprechpartner und ändert keine aktiven individuellen Ansprechpartnerbeziehungen. Gegebenfalls im Anschluss die Funktion "Ansprechpartner auf Firmenstandard zurücksetzen" nutzen.
 FirmSuperActRMSuperDef: Firmenansprechpartner entfernen
-FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden
+FirmSuperActRMSuperActive: Aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden?
 FirmsNotification: Firmen E-Mail versenden
 FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden
 FirmsNotificationTitle: Firmen benachrichtigen
@@ -47,14 +56,23 @@ FilterSupervisor: Hat aktiven Ansprechpartner
 FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört
 FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört
 FilterForeignSupervisor: Hat firmenfremde Ansprechpartner
+FilterIsForeignSupervisee: Ist Ansprechpartner für Firmenfremde
 FilterFirmExtern: Externe Firma
+FilterFirmExternTooltip: Hat die Firma eine Postanschrift im AVS?
+FilterFirmPrimary: Ist primäre Firma in FRADrive
+FilterHasQualification: Hat Firmenangehörige mit aktuell gültiger Qualifikation
 FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig
 FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit
 FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh}
 NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus.
 TableIsDefaultSupervisor: Standardansprechpartner
+TableSuperior: Vorgesetzter
 TableIsDefaultReroute: Standardumleitung
 FormFieldPostal: Benachrichtigungseinstellung
 FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner
-FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert
 FirmSupervisionKeyData: Kennzahlen Ansprechpartner
+CompanyUserPriority: Firmenpriorität
+CompanyUserPriorityTip: Firmenpriorität ist lediglich relativ zu anderen Firmenassoziation der Person
+CompanyUserUseCompanyAddress: Verwendet Firmenkontaktaddresse
+CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterlegt ist
+CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird!

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

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
+# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -7,7 +7,6 @@ FirmSuperForeign: External supervisor
 FirmSuperIrregular: Irregular supervisor
 FirmAssociates: Company associated users
 FirmContact: Company Contact
-FirmNoContact: No general contact information known.
 FirmEmail: General company email
 FirmAddress: Postal address
 FirmDefaultPreferenceInfo: Default setting for new company associates only
@@ -16,11 +15,15 @@ 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 supervisonships?
 FirmActResetMutualSupervision: Supervisors supervise each other
-FirmActAddSupersvisors: Add supervisors
+FirmActResetSupersKeepAll: Keep all
+FirmActResetSupersRemoveAps: Remove default supervisors only
+FirmActResetSupersRemoveAll: Remove all
+FirmActAddSupervisors: Add supervisors
 FirmActAddSupersEmpty: No 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.
-RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}
+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.
@@ -28,17 +31,23 @@ FirmActChangeContactFirmResult: Company contact data changed, affecting future c
 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@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
+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)}
-FirmUserActChangeContact: Change contact data for selected company associates
-FirmUserActMkSuper: Mark as company supervisor
 FirmSuperActNotify: Send message
 FirmSuperActSwitchSuper: Change default company supervisor
-FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired.
+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: Also remove active supervisions within this company
+FirmSuperActRMSuperActive: Terminate active supervisions within this company?
 FirmsNotification: Send company notification e-mail
 FirmNotification fsh: Send e-mail to #{fsh}
 FirmsNotificationTitle: Company notification
@@ -47,14 +56,23 @@ 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
-FirmUserChanges n: Notification settings changed for #{n} company associates
 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!

messages/uniworx/categories/print/de-de-formal.msg

@@ -18,6 +18,7 @@ PrintJobAcknowledgeFailed: Keine Druckaufträge bestätigt aufgrund zwischenzeit
 PrintJobAcknowledgeQuestion n@Int d@Text: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} vom #{d} als gedruckt und versendet bestätigen?
 PrintJobAcknowledgements: Versanddatum von Briefen an
 PrintRecipient: Empfänger
+PrintAffected: Betroffener
 PrintSender !ident-ok: Sender
 PrintCourse: Kursarten
 PrintQualification: Qualifikation
@@ -26,3 +27,6 @@ PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden
 PrintLmsUser: E‑Learning Id
 PrintJobs: Druckaufräge
 PrintLetterType: Brieftypkürzel
+
+MCActDummy: Platzhalter
+CCActDummy: Platzhalter

messages/uniworx/categories/print/en-eu.msg

@@ -18,6 +18,7 @@ PrintJobAcknowledgeFailed: No print-jobs acknowledged, due to intermediate chang
 PrintJobAcknowledgeQuestion n d: Mark #{n} #{pluralENs n "print-job"} issued on #{d} as printed and mailed already?
 PrintJobAcknowledgements: Sent-dates for Letter to
 PrintRecipient: Recipient
+PrintAffected: Affetcted
 PrintSender: Sender
 PrintCourse: Course type
 PrintQualification: Qualification
@@ -26,3 +27,6 @@ PrintManualRenewal: Manual sending of an apron driver's licence renewal letter
 PrintLmsUser: E‑learning id
 PrintJobs: Print jobs
 PrintLetterType: Letter type shorthand
+
+MCActDummy: Placeholder
+CCActDummy: Placeholder

messages/uniworx/categories/qualification/de-de-formal.msg

@@ -9,23 +9,31 @@ QualificationValidIndicator: Gültigkeit
 QualificationValidDuration: Gültigkeitsdauer
 QualificationAuditDuration: Aufbewahrung Audit Log
 QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hinweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen, aber spätestens #{n} Tage nach Abschluss.
+QualificationAuditDurationReuseError: Diese Qualifikation nutzt das E‑Learning einer anderen Qualifikation, für die derzeit keinen Löschzeitraum konfiguriert wurde.
 QualificationRefreshWithin: Erneurerungszeitraum
-QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email.
+QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für eine Benachrichtigung per Email. Bei aktiviertem automatischem E‑Learning wird dieses gestartet und die Benachrichtigung erfolgt per Brief oder Email.
-QualificationRefreshReminder: 2. Erinnerung
+QualificationRefreshReminder: Zweite Erinnerung
-QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen Zugangsdaten, sofern in diesem Zeitraum vor Ablauf noch keine Ablaufbenachrichtigung versendet wurde.
+QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen E‑Learning Zugangsdaten, sofern die Qualifikation noch gültig und das E‑Learning noch offen ist.
 QualificationElearningStart: Wird das E‑Learning automatisch gestartet?
+QualificationElearningRenew: Verlängert ein erfolgreiches E‑Learning die Qualifikation automatisch um die reguläre Gültigkeitsdauer?
+QualificationElearningLimit: Ist die Anzahl der E‑Learning Versuche limitiert?
+QualificationElearningLimitMax n@Int: Maximal #{n} Versuche
+QualificationElearningNoLimit: Nicht limitiert
 QualificationExpiryNotification: Ungültigkeitsbenachrichtigung?
 QualificationExpiryNotificationTooltip: Nutzer werden benachrichtigt, wenn die Qualifikation ungültig wird, sofern der jeweilige Nutzer in seinen Benutzereinstellungen diese Art Benachrichtigung aktiviert hat.
 TableQualificationCountActive: Aktive
 TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation
 TableQualificationCountTotal: Gesamt
+TableQualificationLmsReuses: LMS nutzt
+TableQualificationLmsReusesTooltip: Diese Qualifikation hat kein eigenes E‑Learning, sondern wird über das E‑Learning der angegebenen Qualifikation abgewickelt.
 TableQualificationIsAvsLicence: AVS
 TableQualificationIsAvsLicenceTooltip: Unter welchem Namen wird diese Qualifikation mit dem Ausweisverwaltungssystem (AVS) synchronisiert? Betrifft nur Benutzer mit AVS PersonenID.
 TableQualificationSapExport: SAP
 TableQualificationSapExportTooltip: Wird die Qualifikation an das SAP übermittelt? Betrifft nur Benutzer mit Fraport Personalnummer.
 LmsQualificationValidUntil: Gültig bis
 TableQualificationLastRefresh: Zuletzt erneuert
-TableQualificationLastNotified: Letzte Benachrichtigung
+TableQualificationLastNotified: Letzte Benachrichtigung über erfolgte Gültigkeitsänderung 
+TableQualificationLastNotifiedTooltip: Hier werden ausschließlich Benachrichtigungen berücksichtigt, die über einen bereits erfolgten Ablauf/Entzug/Wiedererteilung informieren. Dies ignoriert insbesondere reguläre Verlängerung, z.B. durch E-Learning.
 TableQualificationFirstHeld: Erstmalig
 TableQualificationBlockedDue: Entzug
 TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst?
@@ -46,11 +54,13 @@ QualificationExpired: Ungültig seit
 LmsUser: Inhaber
 LmsURL: Link E‑Learning
 TableLmsEmail: E‑Mail
-TableLmsIdent: E-Learning Benutzer
+TableLmsIdent: E‑Learning Benutzer
 TableLmsElearning: E‑Learning
+TableLmsElearningRenews: Automatische Verlängerung
+TableLmsElearningLimit: Maximale Versuche
 TableLmsPin: E‑Learning Passwort
-TableLmsResetPin: E-Learning Passwort zurücksetzen?
+TableLmsResetPin: E‑Learning Passwort zurücksetzen?
-TableLmsDatePin: E-Learning Passwort erstellt
+TableLmsDatePin: E‑Learning Passwort erstellt
 TableLmsDate: Datum
 TableLmsDelete: Löschen?
 TableLmsStaff: Interner Mitarbeiter?
@@ -88,7 +98,8 @@ LmsReportInsert: Neues LMS Ereignis
 LmsReportUpdate: LMS Ereignis Aktualisierung
 LmsReportCsvExceptionDuplicatedKey: CSV-Import LmsReport fand uneindeutigen Schlüssel
 LmsDirectUpload: Direkter Upload für automatisierte Systeme
-LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
+LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde!
+LmsErrorNoRenewElearning: Fehler: Erfoglreiches E‑Learning verlängert die Qualifikation nicht automatisch, da die Gültigkeitsdauer nicht festgelegt wurde!
 MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden
 MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
 MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort ungültig
@@ -106,11 +117,13 @@ QualificationActUnblock: Entzug aufheben
 QualificationActRenew: Qualifikation regulär verlängern
 QualificationActGrant: Qualifikation vergeben
 QualificationActGrantWarning: Diese Funktion ist nur für seltene Ausnahmefälle vorgesehen! Ein Entzug wird ggf. aufgehoben.
+QualificationActStartELearning: E‑Learning für gültige Inhaber (neu) starten
+QualificationActStartELearningStatus l@QualificationShorthand n@Int m@Int: E‑Learning #{l} für #{n}/#{m} Teilnehmer (neu) gestartet. Hinweis: Es kann länger dauern, bis das LMS tatsächlich startet.
 QualificationStatusBlock   l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
 QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
 LmsInactive: Aktuell kein E‑Learning aktiv
 LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach.
-LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden.
+LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden. Bitte setzen Sie sich mit uns in Verbindung, wenn Sie die Qualifikation verlängern möchten und noch nicht wissen, wie Sie das tun können. Ignorieren Sie diese automatisch generierte Erinnerung, falls Sie sich bereits um die Verlängerung gekümmert haben
 LmsRenewalReminder: Erinnerung
 LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden
 LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen
@@ -119,7 +132,7 @@ LmsActReset: E‑Learning Fehlversuche zurücksetzen und entsperren
 LmsActResetInfo: E‑Learning Login, Passwort und Fortschritt bleiben unverändert, eine neue Benachrichtigung ist nicht notwendig. Nur möglich für bereits gesperrte Lerner. Es kann bis zu 2 Stunden dauern, bis das LMS die Anfrage umgesetzt hat.
 LmsActResetFeedback n@Int m@Int: Für #{n}/#{m} E‑Learning Nutzer wurden alle Fehlversuche zurückgesetzt.
 LmsActRestart: E‑Learning komplett neu starten
-LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Fahrlizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat.
+LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Lizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat.
 LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E‑Learning Nutzer wurden komplett neu gestartet mit neuem Login und Passwort.
 LmsActRestartExtend: Gültig bis ggf. erhöhen für die nächsten # Tage
 LmsActRestartUnblock: Entzug ggf. aufheben

messages/uniworx/categories/qualification/en-eu.msg

@@ -9,23 +9,31 @@ QualificationValidIndicator: Validity
 QualificationValidDuration: Validity period
 QualificationAuditDuration: Audit log retention period
 QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier, at most #{n} days after closing.
+QualificationAuditDurationReuseError: This qualification reuses the e‑learning from another qualification, which has no audit duration configured.
 QualificationRefreshWithin: Refresh within
-QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
+QualificationRefreshWithinTooltip: Optional period before expiry to send a notification by email. If e‑learning is set to start automatically, it will be started and e‑learning credentials are send with this notification by post or email.
-QualificationRefreshReminder: 2. Reminder
+QualificationRefreshReminder: Second reminder
-QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, provided that no renewal notification was sent in this period before expiry.
+QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, including the existing credentials, provided that the e‑learning is still undecided and the qualification has not yet expired.
 QualificationElearningStart: Is e‑learning automatically started?
+QualificationElearningRenew: Does successful e‑learning automatically extend a qualification by the default validity period?
+QualificationElearningLimit: Is the number of e‑learning attempts limited?
+QualificationElearningLimitMax n: #{n} attempts maximum
+QualificationElearningNoLimit: No limit
 QualificationExpiryNotification: Invalidity notification?
 QualificationExpiryNotificationTooltip: Qualification holder are notfied upon invalidity, provided they have activated such notification in their user settings.
 TableQualificationCountActive: Active
 TableQualificationCountActiveTooltip: Number of currently valid qualification holders
 TableQualificationCountTotal: Total
+TableQualificationLmsReuses: Reuse LMS 
+TableQualificationLmsReusesTooltip: This qualification reuses the e‑learning of the given qualification, instead of having a separate e‑learning of its own.
 TableQualificationIsAvsLicence: AVS driving license
 TableQualificationIsAvsLicenceTooltip: Under which name is this qualification synchronized with AVS, if any? Only applies to qualification holders having an AVS PersonID.
 TableQualificationSapExport: Sent to SAP
 TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number.
 LmsQualificationValidUntil: Valid until
 TableQualificationLastRefresh: Last renewed
-TableQualificationLastNotified: Last notified
+TableQualificationLastNotified: Last notified about validity change
+TableQualificationLastNotifiedTooltip: The date of the last notification about any already effective change in validity due to revocation or reissue. This does not entail regular validity extensions, e.g. due to e-learning.
 TableQualificationFirstHeld: First held
 TableQualificationBlockedDue: Revocations
 TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended?
@@ -49,6 +57,8 @@ TableLmsEmail: Email
 TableLmsIdent: E‑learning user
 TableLmsPin: E‑learning password
 TableLmsElearning: E‑learning
+TableLmsElearningRenews: Automatic renewal
+TableLmsElearningLimit: Max attempts
 TableLmsResetPin: Reset E‑learning password?
 TableLmsDatePin: E‑learning password created
 TableLmsDate: Date
@@ -88,7 +98,8 @@ LmsReportInsert: New LMS event
 LmsReportUpdate: Update of LMS event
 LmsReportCsvExceptionDuplicatedKey: CSV Import LmsReport with ambiguous key
 LmsDirectUpload: Direct upload for automated systems
-LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set.
+LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set!
+LmsErrorNoRenewElearning: Error: E‑learning will not automatically extend validity due to validity duration not being set!
 MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly
 MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon
 MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid
@@ -106,11 +117,13 @@ QualificationActUnblock: Clear revocation
 QualificationActRenew: Renew qualification
 QualificationActGrant: Grant qualification
 QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone.
+QualificationActStartELearning: Manually (re)start e‑learning for valid qualification holders
+QualificationActStartELearningStatus l n m: E‑learning #{l} (re)started for #{n}/#{m} users. Note: It may take a while, until the e‑learning is activated.
 QualificationStatusBlock   l n m: #{n}/#{m} #{l} revoked
 QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
 LmsInactive: Currently no active e‑learning
 LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter.
-LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through e‑learning only.
+LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through e‑learning only. Please contact us, if you do not yet know how to renew this qualification. Ignore this automatically generated reminder email, if you have made arrangements for the renewal of this qualification already.
 LmsRenewalReminder: Reminder
 LmsActNotify: Resend e‑learning notification by post or email
 LmsActRenewPin: Randomly replace e‑learning password

messages/uniworx/categories/send/send_notifications/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -75,10 +75,11 @@ NotPassed: Nicht bestanden
 
 #userAuthModeUpdate.hs + templates
 MailSubjectUserAuthModeUpdate: Ihr FRADrive-Login
-UserAuthPasswordEnabled: Sie können sich nun mit einer FRADrive-internen Kennung einloggen.
+UserAuthModeChangedToLDAP: Sie können sich nun mit Ihrer Fraport AG Kennung (Büko) in FRADrive einloggen.
-UserAuthPasswordDisabled: Sie können sich nun nicht mehr mit Ihrer FRADrive-internen Kennung einloggen.
+UserAuthModeChangedToPWHash: Sie können sich nun mit einer FRADrive-internen Kennung einloggen.
-AuthExternalLoginTip: Sollten Sie Zugriff zu einem von FRADrive unterstützten externen Account (Azure-Login über Fraport-Kennung, Fraport-BüKo-Login) besitzen, so können Sie sich mit Ihren externen Login-Daten in FRADrive einloggen.
+UserAuthModeChangedToNoLogin: Ihr Login auf der FRADrive Webseite wurde deaktiviert, aber ihr FRADrive Konto besteht weiterhin. Gültigkeit und Verlängerungen Ihrer Qualifikationen sind dadurch nicht beeinträchtigt. Wenden Sie sich an die Fahrschuladmins, wenn der Login auf der FRADrive Webseite benötigt werden sollte.
-PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie aus Sicherheitsgründen in einer separaten E-Mail.
+AuthPWHashTip: Sie müssen nun das mit "FRADrive-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden.
+PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail.
 MailFradrive !ident-ok: FRADrive
 MailBodyFradrive: ist die Führerscheinverwaltungsapp der Fraport AG.
 

messages/uniworx/categories/send/send_notifications/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -75,9 +75,10 @@ NotPassed: Failed
 
 #userAuthModeUpdate.hs + templates
 MailSubjectUserAuthModeUpdate: Your FRADrive login
-UserAuthPasswordEnabled: You can now log in using your FRADrive-internal account credentials.
+UserAuthModeChangedToLDAP: You can now log in to FRADrive using your Fraport AG account (Büko)
-UserAuthPasswordDisabled: You can no longer log in using your FRADrive-internal account credentials.
+UserAuthModeChangedToPWHash: You can now log in using your FRADrive-internal account
-AuthExternalLoginTip: If you have access to an external account supported by FRADrive (Azure login via Fraport identification, Fraport-BüKo login), you can login in FRADrive using your external credentials.
+UserAuthModeChangedToNoLogin: Your login for the FRADrive website has been deactivated, but you FRADrive account persists. This has no effect on you qualifications. Please contact the driving school admins, if you need new login credentials for the FRADrive website.
+AuthPWHashTip: You now need to use the login form labeled "FRADrive login". Please ensure that you have already set a password when you try to log in.
 PasswordResetEmailIncoming: For security reasons you will receive a link to the page on which you can set and later change your password in a separate email.
 MailFradrive: FRADrive
 MailBodyFradrive: is the apron driver's licence management app of Fraport AG.

messages/uniworx/categories/settings/auth_settings/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -45,8 +45,8 @@ AuthTagUserSubmissions: Abgaben erfolgen durch Kursartteilnehmer:innen
 AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektor:innen
 AuthTagCorrectionAnonymous: Korrektur ist anonymisiert
 AuthTagSelf: Nutzer:in greift nur auf eigene Daten zu
-AuthTagIsExternal: Nutzer:in meldet sich mit extern verwalteten Logindaten an
+AuthTagIsLDAP: Nutzer:in meldet sich mit Fraport AG Kennung an
-AuthTagIsInternal: Nutzer:in meldet sich mit FRADrive-internen Logindaten an
+AuthTagIsPWHash: Nutzer:in meldet sich mit FRADrive spezifischer Kennung an
 AuthTagAuthentication: Nutzer:in ist angemeldet, falls erforderlich
 AuthTagRead: Zugriff ist nur lesend
 AuthTagWrite: Zugriff ist i.A. schreibend

messages/uniworx/categories/settings/auth_settings/en-eu.msg

@@ -1,4 +1,4 @@
-# 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>, Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -45,8 +45,8 @@ AuthTagUserSubmissions: Submissions are made by course type participants
 AuthTagCorrectorSubmissions: Submissions are registered by correctors
 AuthTagCorrectionAnonymous: Correction is anonymised
 AuthTagSelf: User is only accessing their only data
-AuthTagIsExternal: User logs in using externally managed credentials
+AuthTagIsLDAP: User logs in using their Fraport AG account
-AuthTagIsInternal: User logs in using FRADrive-internal credentials
+AuthTagIsPWHash: User logs in using their FRADrive specific account
 AuthTagAuthentication: User is authenticated
 AuthTagRead: Access is read only
 AuthTagWrite: Access might write

messages/uniworx/categories/settings/personal_settings/de-de-formal.msg

@@ -25,10 +25,14 @@ PersonalInfoTutorialsWip: Die Anzeige von Kurse, zu denen Sie angemeldet sind wi
 ProfileGroupSubmissionDates: Bei Gruppenabgaben wird kein Datum angezeigt, wenn Sie die Gruppenabgabe nie selbst hochgeladen haben.
 ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle Einteilungen als Korrektor zu einem Übungsblatt. Auch ohne Einteilung können Korrekturen einzeln zugewiesen werden, welche hier dann nicht aufgeführt werden.
 ProfileCorrections: Auflistung aller zugewiesenen Korrekturen
-Remarks: Hinweise
+Remarks: Hinweis:
 
-ProfileSupervisor: Übergeordnete Ansprechpartner
+ProfileNoSupervisor: Keine übergeordneten Ansprechpartner vorhanden
-ProfileSupervisee: Ist Ansprechpartner für
+ProfileSupervisor n@Int m@Int: #{n} #{pluralDE n "übergeordneter" "übergeordnete"} Ansprechpartner#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
+ProfileSupervisorRemark n@Int m@Int l@Int: #{m} von #{n} #{pluralDE m "übergeordneter" "übergeordnete"} Ansprechpartner mit Benachrichtigungsumleitung#{noneMoreDE l "" (", davon " <> tshow l <> " mit postalischer Benachrichtigung")}
+ProfileNoSupervisee: Ist kein Ansprechpartner für irgendjemand
+ProfileSupervisee n@Int m@Int: Ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
+ProfileSuperviseeRemark n@Int m@Int: Dieser Nutzer ist Ansprechpartner für #{n} #{pluralDE n "Person" "Personen"}#{noneMoreDE m "" (", davon " <> tshow m <> " mit Benachrichtigungsumleitung")}
 
 UserTelephone: Telefon
 UserMobile: Mobiltelefon

messages/uniworx/categories/settings/personal_settings/en-eu.msg

@@ -25,10 +25,14 @@ PersonalInfoTutorialsWip: The feature to display courses you have registered for
 ProfileGroupSubmissionDates: No date is shown for group submissions if you have never uploaded the submission yourself.
 ProfileCorrectorRemark: The table above only shows registration as a corrector in principle. Even without registration corrections can be assigned individually and are not listed.
 ProfileCorrections: List of all assigned corrections
-Remarks: Remarks
+Remarks: Remark:
 
-ProfileSupervisor: Supervised by
+ProfileNoSupervisor: Is not supervised by anynone
-ProfileSupervisee: Supervises
+ProfileSupervisor n m: #{pluralENsN n "supervisor"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")}
+ProfileSupervisorRemark n@Int m@Int l@Int: #{m} of #{n} #{pluralENs m "supervisor"} with active notification rerouting#{noneMoreEN l "" (", and " <> tshow l <> "of these prefer postal notifications")}
+ProfileNoSupervisee: Does not supervise anynone
+ProfileSupervisee n m: Supervises  #{pluralENsN n "person"} #{noneMoreEN m "" ("with " <> tshow m <> " active notification rerouting")}
+ProfileSuperviseeRemark n m: This person supervises #{pluralENsN n "person"}#{noneMoreEN m "" (" with " <> tshow m <> " having active notifications rerouting to this user")}
 
 UserTelephone: Phone
 UserMobile: Mobile

messages/uniworx/categories/user/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -22,6 +22,7 @@ AdminUserPostAddress: Postalische Anschrift
 AdminUserPrefersPostal: Briefe anstatt Email bevorzugt
 AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails
 AdminUserNoPassword: Kein Passwort gesetzt
+AdminUserPinPassNotIncluded: Hinweis: Das Passwort wird hier zur Bequemlichkeit zusätzlich angezeigt und ist selbstverständlich nicht im originalem Inhalt enthalten.
 AdminUserAssimilate: Diesen Benutzer assimilieren von
 UserAdded: Benutzer erfolgreich angelegt
 UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
@@ -37,9 +38,10 @@ AuthPWHashAlreadyConfigured: Nutzer:in meldet sich bereits mit FRADrive spezifis
 AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennung an
 UsersCourseSchool: Bereich
 ActionNoUsersSelected: Keine Benutzer:innen ausgewählt
-SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
+SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen, die Ausführung wird mehrere Minuten benötigen!
-SynchroniseUserdbUserQueued n@Int: Benutzerdatenbank-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
+SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden, die Ausführung wird eine Weile brauchen!
-SynchroniseUserdbAllUsersQueued: Benutzerdatenbank-Synchronisation von allen Benutzer:innen angestoßen
+SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, die Ausführung wird mehrere Minuten benötigen!
+SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen, die Ausführung kann eine Weile brauchen!
 UserListTitle: Komprehensive Benutzerliste
 AccessRightsSaved: Berechtigungen erfolgreich verändert
 AccessRightsNotChanged: Berechtigungen wurden nicht verändert
@@ -48,7 +50,6 @@ AuthLDAPInvalidLookup: Bestehender Nutzer/Bestehende Nutzerin konnte nicht einde
 AuthLDAPAlreadyConfigured: Nutzer:in meldet sich bereits per Fraport AG Kennung in FRADrive an
 AuthLDAPConfigured: Nutzer:in meldet sich nun per Fraport AG Kennung in FRADrive an
 AuthLDAP !ident-ok: Fraport AG Kennung
-AuthAzure: Azure-Account
 AuthNoLogin: Kein Login erlaubt.
 PasswordResetQueued: Link zum Passwort-Zurücksetzen versandt
 UserAssimilateUser: Benutzer:in
@@ -90,20 +91,29 @@ NewPasswordLink: Neues Passwort setzen
 UserAccountDeleteWarning: Achtung, dies löscht den kompletten Benutzer/die komplette Benutzerin unwiderruflich und mit allen assoziierten Daten aus der Datenbank. Prüfungsdaten müssen jedoch langfristig gespeichert bleiben!
 UserAvsSync: AVS-Synchronisieren
 UserLdapSync: LDAP-Synchronisieren
-AllUsersLdapSync: Alle LDAP-Synchronisieren
 UserHijack: Sitzung übernehmen
 UserAddSupervisor: Ansprechpartner hinzufügen
 UserSetSupervisor: Ansprechpartner ersetzen
 UserRemoveSupervisor: Alle Ansprechpartner entfernen
+UserRemoveSubordinates: Alle Ansprechpartnerbeziehungen zu Untergebenen beenden
 UserIsSupervisor: Ist Ansprechpartner
+UserAvsSwitchCompany: Als Primärfirma verwenden
+UserAvsSwitchCompanyField: Primärfirma auswählen
+UserAvsCompanySwitched c@CompanyShorthand: Primärfirma gewechselt zu #{tshow c}
+AllUsersLdapSync: Alle LDAP-Synchronisieren
+AllUsersAvsSync: Alle AVS-Synchronisieren
+ThisUserLdapSync: LDAP Synchronisation
+ThisUserAvsSync: AVS Synchronisation
+AuthKindLDAP: Fraport AG Kennung
+AuthKindPWHash: FRADrive Kennung
+AuthKindNoLogin: Kein Login möglich
 Name !ident-ok: Name
 UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt.
 UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden!
 UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht.
-
+UsersRemoveSubordinates usr@Int: Alle Ansprechpartnerbeziehungen für #{tshow usr} #{pluralDE usr "ehemaligen" "ehemalige"} Ansprechpartner gelöscht.
-AdminUserAuthentication: Authentification
+UserCompanyReason: Begründung der Firmenassoziation
-AdminUserAuthLastSync: Zuletzt synchronisiert
+UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
-AuthKindLDAP: Fraport-AG-Kennung (LDAP)
+UserSupervisorReason: Begründung Ansprechpartner
-AuthKindAzure: Azure-Login
+UserSupervisorReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
-AuthKindPWHash: Interne FRADrive-Kennung
+AdminUserAllNotifications: Alle Benachrichtigungen and diesen Benutzer
-AuthKindNoLogin: Kein Login möglich

messages/uniworx/categories/user/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -22,6 +22,7 @@ AdminUserPostAddress: Postal Address
 AdminUserPrefersPostal: Prefers postal letters over email
 AdminUserPinPassword: Password used for PDF attachments to emails
 AdminUserNoPassword: No password set
+AdminUserPinPassNotIncluded: Note: the password is shown here only for convenience, but is not contained in the original content, of course.
 AdminUserAssimilate: Assimilate user by another user
 UserAdded: Successfully added user
 UserCollision: Could not create user due to uniqueness constraint
@@ -37,9 +38,10 @@ AuthPWHashAlreadyConfigured: User already logs in using their FRADrive specific
 AuthPWHashConfigured: User now logs in using their FRADrive specific account
 UsersCourseSchool: Department
 ActionNoUsersSelected: No users selected
-SynchroniseAvsUserQueued n: Triggered AVS synchronisation of #{n} #{pluralEN n "user" "users"}.
+SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
-SynchroniseUserdbUserQueued n: Triggered user database synchronisation of #{n} #{pluralEN n "user" "users"}.
+SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today, which may take quite a while to complete.
-SynchroniseUserdbAllUsersQueued: Triggered user database synchronisation of all users
+SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
+SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users, which may take quite a while to complete.
 UserListTitle: Comprehensive list of users
 AccessRightsSaved: Successfully updated permissions
 AccessRightsNotChanged: Permissions left unchanged
@@ -48,7 +50,6 @@ AuthLDAPInvalidLookup: Existing user could not be uniquely matched with a LDAP e
 AuthLDAPAlreadyConfigured: User already logs in using their Fraport AG account
 AuthLDAPConfigured: User now logs in using their Fraport AG account
 AuthLDAP: Fraport AG account
-AuthAzure: Azure account
 AuthNoLogin: No login allowed.
 PasswordResetQueued: Sent link to reset password
 UserAssimilateUser: User
@@ -90,20 +91,29 @@ NewPasswordLink: Set password
 UserAccountDeleteWarning: Caution, this permanently deletes users and all of their associated data. Exam results must be stored long term!
 UserAvsSync: Synchronise with AVS
 UserLdapSync: Synchronise with LDAP
-AllUsersLdapSync: Synchronise all with LDAP
 UserHijack: Hijack session
 UserAddSupervisor: Add supervisor
 UserSetSupervisor: Replace supervisors
 UserRemoveSupervisor: Set to unsupervised
+UserRemoveSubordinates: Remove all subordinates
 UserIsSupervisor: Is supervisor
+UserAvsSwitchCompany: Use as primary company
+UserAvsSwitchCompanyField: Select primary company
+UserAvsCompanySwitched c: Primary company switched to #{tshow c}
+AllUsersLdapSync: Synchronise all with LDAP
+AllUsersAvsSync: Synchronise all with AVS
+ThisUserLdapSync: Synchronise user with LDAP
+ThisUserAvsSync: Synchronise user with AVS
+AuthKindLDAP: Fraport AG account
+AuthKindPWHash: FRADrive account
+AuthKindNoLogin: No login
 Name: Name
 UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{pluralENsN usr "user"} set.
 UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified!
 UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
-
+UsersRemoveSubordinates usr: Removed all subordinates for #{pluralENsN usr "previous supervisor"}.
-AdminUserAuthentication: Authentifizierung
+UserCompanyReason: Reason for company association
-AdminUserAuthLastSync: Last synchronised
+UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
-AuthKindLDAP: Fraport AG account (LDAP)
+UserSupervisorReason: Reason for supervision
-AuthKindAzure: Azure account
+UserSupervisorReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
-AuthKindPWHash: Internal FRADrive login
+AdminUserAllNotifications: All notification sent to this user
-AuthKindNoLogin: No login

messages/uniworx/misc/de-de-formal.msg

@@ -4,24 +4,31 @@
 
 #messages or constructors that are used all over the code
 
-Logo !ident-ok: Uni2work
+Logo !ident-ok: FRADrive
-EmailInvitationWarning: Diese Adresse konnte keinem Uni2work-Benutzer/keiner Uni2work-Benutzerin zugeordnet werden. Es wird eine Einladung per E-Mail versandt.
+EmailInvitationWarning: Diese Adresse konnte keinem FRADrive-Benutzer/-Benutzerin zugeordnet werden. Es wird eine Einladung per E-Mail versandt.
 BoolIrrelevant !ident-ok: —
 FieldPrimary: Hauptfach
 FieldSecondary: Nebenfach
 MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich
 MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick
 WeekDay: Wochentag
+Hours: Stunden
 LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse
 Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"}
 Days num@Int64: #{num} #{pluralDE num "Tag" "Tage"}
+NoAutomaticUpdateTip: Dieser Wert wurde manuell editiert und wird daher nicht mehr automatisch durch as AVS aktualisiert.
+AddressIsLinkedTip: Verlinkte Postaddresse: Für diesen Benutzer ist keine individuelle Postadresse gespeichert, die Adresse wurde stattdessen aus der Firmenzugehörigkeit abgeleitet.
 
 ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv
 
 AvsNoLicence: Keine Fahrberechtigung
 AvsLicenceVorfeld: Vorfeld Fahrberechtigung
 AvsLicenceRollfeld: Rollfeld Fahrberechtigung
+AvsNoLicenceGuest: Keine Fahrberechtigung (Gast, Fahrberechtigungserwerb nicht möglich)
 
 PaginationSize: Einträge pro Seite
 PaginationPage: Angzeigte Seite
 PaginationError: Paginierung Parameter dürfen nicht negativ sein
+
+NullDeletes: Zum Löschen NULL eingeben.
+SortPriority: Sortierungspriorität

messages/uniworx/misc/en-eu.msg

@@ -4,24 +4,31 @@
 
 #messages or constructors that are used all over the Code
 
-Logo: Uni2work
+Logo: FRADrive
-EmailInvitationWarning: This address could not be matched to any Uni2work user. An invitation will be sent via email.
+EmailInvitationWarning: This address could not be matched to any FRADrive user. An invitation will be sent via email.
 BoolIrrelevant: —
 FieldPrimary: Major
 FieldSecondary: Minor
 MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated)
 MultiSelectTip: Multiple selection and desection via Ctrl-Click
 WeekDay: Day of the week
+Hours: Hours
 LdapIdentificationOrEmail: Fraport AG-Kennung / email address
 Months num: #{num} #{pluralEN num "Month" "Months"}
 Days num: #{num} #{pluralEN num "Day" "Days"}
+NoAutomaticUpdateTip: This particular value receives no automatic AVS updates, since it has been edited manually.
+AddressIsLinkedTip: Linked postal address: No individual postal address is stored for this user, instead a postal address was inferred from the user's company association.
 
 ClusterVolatileQuickActionsEnabled: Quick actions enabled
 
 AvsNoLicence: No driving licence
 AvsLicenceVorfeld: Apron driving licence
 AvsLicenceRollfeld: Maneuvering area driving licence
+AvsNoLicenceGuest: No driving licence (Guest account, cannot acquire a diriving licence)
 
 PaginationSize: Rows per Page
 PaginationPage: Page to show
 PaginationError: Pagination parameter must not be negative
+
+NullDeletes:  Enter NULL to delete.
+SortPriority: Sort order priority

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -25,7 +25,6 @@ MenuInstance: Instanz-Identifikation
 MenuHealth: Instanz-Zustand
 MenuHealthInterface: Schnittstellen Zustand
 MenuHelp: Hilfe
-MenuAccount: Konto
 MenuProfile: Anpassen
 MenuLogin !ident-ok: Login
 MenuLogout !ident-ok: Logout
@@ -143,13 +142,19 @@ MenuSap: SAP Schnittstelle
 
 MenuAvs: AVS Schnittstelle
 MenuAvsSynchError: AVS Problemübersicht
-MenuExternalUser: Externe Benutzer
+MenuLdap: LDAP Schnittstelle
-MenuApc: Druckerei
+MenuApc: Druck
 MenuPrintSend: Manueller Briefversand
 MenuPrintDownload: Brief herunterladen
 MenuPrintLog: LPR Schnittstelle
 MenuPrintAck: Druckbestätigung
 
+MenuCommCenter: Benachrichtigungen
+MenuMailCenter: E‑Mails
+MenuMailHtml !ident-ok: Html
+MenuMailPlain !ident-ok: Text
+MenuMailAttachment: Anhang
+
 MenuApiDocs: API-Dokumentation (Englisch)
 MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)
 

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -25,7 +25,6 @@ MenuInstance: Instance identification
 MenuHealth: Instance health
 MenuHealthInterface: Interface health
 MenuHelp: Support
-MenuAccount: Account
 MenuProfile: Settings
 MenuLogin: Login
 MenuLogout: Logout
@@ -143,13 +142,19 @@ MenuSap: SAP Interface
 
 MenuAvs: AVS Interface
 MenuAvsSynchError: AVS Problem Overview
-MenuExternalUser: External users
+MenuLdap: LDAP Interface
-MenuApc: Printing
+MenuApc: Print
 MenuPrintSend: Send Letter
 MenuPrintDownload: Download Letter
 MenuPrintLog: LPR Interface
 MenuPrintAck: Acknowledge Printing
 
+MenuCommCenter: Notifications
+MenuMailCenter: Email
+MenuMailHtml: Html
+MenuMailPlain: Text
+MenuMailAttachment: Attachment
+
 MenuApiDocs: API documentation
 MenuSwagger: OpenAPI 2.0 (Swagger)
 

messages/uniworx/utils/table_column/de-de-formal.msg

@@ -73,15 +73,19 @@ TableDiffDaysTooltip: Zeitspanne nach ISO 8601. Beispiel: "P2Y3M4D" ist eine Zei
 TableExamOfficeLabel: Label-Name
 TableExamOfficeLabelStatus: Label-Farbe
 TableExamOfficeLabelPriority: Label-Priorität
+TableQualification: Qualifikation
 TableQualifications: Qualifikationen
 TableCompany: Firma
 TableCompanyFilter: Firma oder Nummer
 TableCompanyShort: Firmenkürzel
 TableCompanies: Firmen
+TablePrimeCompany: Primäre Firma
 TableCompanyNo: Firmennummer
 TableCompanyNos: Firmennummern
 TableCompanyUser: Firmenangehöriger
 TableCompanyNrUsers: Firmenangehörige
+TableCompanyNrSecondaryUsers: Sekundäre Firmenangehörige
+TableCompanyReason: Notiz
 TableCompanyNrSupers: Ansprechpartner
 TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner
 TableCompanyNrEmpRerouted: Firmenangehörige mit Umleitung
@@ -91,8 +95,11 @@ TableCompanyNrSupersDefault: Standard Ansprechpartner
 TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
 TableCompanyNrRerouteDefault: Standard Umleitungen
 TableCompanyNrRerouteActive: Aktive Umleitungen
+TableRerouteActive: Umleitung
 TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
 TableSupervisor: Ansprechpartner
+TableSupervisee: Ansprechpartner für
+TableReason: Begründung
 TableCreationTime: Erstellungszeit
 TableJob !ident-ok: Job
 TableJobContent !ident-ok: Parameter
@@ -100,9 +107,11 @@ TableJobLockTime: Bearbeitung seit
 TableJobLockInstance: Bearbeiter
 TableJobCreationInstance: Ersteller
 ActJobDelete: Job entfernen
+ActJobDeleteForce n@Int: Auch vor #{pluralDEnN n "Minute"} gesperrte Jobs entfernen
 TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt
 TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrennt angegeben werden, wovon mindestens eines erfüllt werden muss.
 TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol.
+TableFilterCommaPlusShort: Unterstützt mehrere Kriterien mit Komma-Plus, siehe oben.
 TableFilterCommaName: Mehrere Namen mit Komma trennen.
 TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht.
 TableUserEdit: Benutzer bearbeiten

messages/uniworx/utils/table_column/en-eu.msg

@@ -73,15 +73,19 @@ TableDiffDaysTooltip: Duration given according to ISO 8601. Example: "P2Y3M4D" i
 TableExamOfficeLabel: Label name
 TableExamOfficeLabelStatus: Label colour
 TableExamOfficeLabelPriority: Label priority
+TableQualification: Qualification
 TableQualifications: Qualifications
 TableCompany: Company
 TableCompanyFilter: Company/Nr
 TableCompanyShort: Company shorthand
 TableCompanies: Companies
+TablePrimeCompany: Primary company
 TableCompanyNo: Company number
 TableCompanyNos: Company numbers
 TableCompanyUser: Associate
 TableCompanyNrUsers: Associates
+TableCompanyNrSecondaryUsers: Secondary Associates
+TableCompanyReason: Note
 TableCompanyNrSupers: Supervisors
 TableCompanyNrEmpSupervised: Supervised employees 
 TableCompanyNrEmpRerouted: Employees having reroute
@@ -91,8 +95,11 @@ TableCompanyNrSupersDefault: Default supervisors
 TableCompanyNrForeignSupers: External Supervisors
 TableCompanyNrRerouteDefault: Default reroutes
 TableCompanyNrRerouteActive: Active reroutes
+TableRerouteActive: Reroute
 TableCompanyPostalPreference: Default notification preference
 TableSupervisor: Supervisor
+TableSupervisee: Supervisor for
+TableReason: Reason
 TableCreationTime: Creation
 TableJob !ident-ok: Job
 TableJobContent !ident-ok: Parameters
@@ -100,9 +107,11 @@ TableJobLockTime: Lock time
 TableJobLockInstance: Worker
 TableJobCreationInstance: Creator
 ActJobDelete: Delete job
+ActJobDeleteForce n: Also delete jobs locked #{pluralENsN n "minute"} ago
 TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted
 TableFilterComma: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled.
 TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol.
+TableFilterCommaPlusShort: Support multiple criteria with comma/plus, see above.
 TableFilterCommaName: Separate names by comma.
 TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact.
 TableUserEdit: Edit user

messages/uniworx/utils/utils/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -25,6 +25,7 @@ RGTutorialParticipants tutn@TutorialName: Kursteilnehmer:innen (#{tutn})
 RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“
 RGSheetSubmittor shn@SheetName: Abgebende für das Übungsblatt „#{shn}“
 CommSubject: Betreff
+CommContent: Inhalt
 CommAttachments: Anhänge
 CommAttachmentsTip: Im Allgemeinen ist es vorzuziehen Dateien, die Sie mit den Empfängern teilen möchten, als Material hochzuladen (und ggf. in der Nachricht zu verlinken). So ist die Datei für die Empfänger dauerhaft abrufbar und auch Personen, die sich z.B. erst später zur Kursart anmelden, haben Zugriff auf die Datei.
 CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
@@ -82,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hie
 AmbiguousEmail: E-Mail-Adresse nicht eindeutig
 InvalidEmailAddress: E-Mail-Adresse ist ungültig
 InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig
+MailFileAttachment: Dateianhang
 UtilExamResultGrade: Note
 UtilExamResultPass: Bestanden/Nicht Bestanden
 UtilExamResultNoShow: Nicht erschienen
@@ -96,6 +98,7 @@ RoomReferenceLinkLink !ident-ok: Link
 RoomReferenceLinkLinkPlaceholder !ident-ok: URL
 RoomReferenceLinkInstructions: Anweisungen
 RoomReferenceLinkInstructionsPlaceholder: Anweisungen
+UtilNoneSet: Keine angegeben
 UtilEmptyChoice: Auswahl war leer
 UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert.
 MultiNoSelection: Keine Auswahl
@@ -159,5 +162,3 @@ SheetTypeNormal !ident-ok: Normal
 SheetTypeBonus !ident-ok: Bonus
 
 InvalidFormAction: Keine Aktion ausgeführt wegen ungültigen Formulardaten
-
-InvalidUuid: Invalide UUID!

messages/uniworx/utils/utils/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
+# SPDX-FileCopyrightText: 2023 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -25,6 +25,7 @@ RGTutorialParticipants tutn: Course participants (#{tutn})
 RGExamRegistered examn: Registered for exam “#{examn}”
 RGSheetSubmittor shn: Submitted for exercise sheet “#{shn}”
 CommSubject: Subject
+CommContent: Content
 CommAttachments: Attachments
 CommAttachmentsTip: In general it is preferable to upload files as course type material instead of sending them as attachments. You can then link to the material from the message. The file is then permanently accessable to the recipients and to persons that, for example, register for the Course type at a later date.
 CommSuccess n: Message was sent to #{n} #{pluralEN n "recipient" "recipients"}
@@ -82,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email
 AmbiguousEmail: Email address is ambiguous
 InvalidEmailAddress: Email address is invalid
 InvalidEmailAddressWith e: Email asdress #{show e} is invalid
+MailFileAttachment: Attached file
 UtilExamResultGrade: Grade
 UtilExamResultPass: Passed/Failed
 UtilExamResultNoShow: Not present
@@ -96,6 +98,7 @@ RoomReferenceLinkLink: Link
 RoomReferenceLinkLinkPlaceholder: URL
 RoomReferenceLinkInstructions: Instructions
 RoomReferenceLinkInstructionsPlaceholder: Instructions
+UtilNoneSet: None set
 UtilEmptyChoice: Empty selection
 UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty.
 MultiNoSelection: No selection
@@ -159,5 +162,3 @@ SheetTypeNormal: Normal
 SheetTypeBonus: Bonus
 
 InvalidFormAction: No action taken due to invalid form data
-
-InvalidUuid: Invalid UUID!

models/audit.model

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -8,7 +8,7 @@ TransactionLog
   instance InstanceId
   initiator UserId Maybe -- User associated with performing this action
   remote IP Maybe -- Remote party that triggered this action via HTTP
-  info Value -- JSON-encoded `Transaction`
+  info Value -- JSON-encoded `Transaction`. Value allows full backwards compatibility
   deriving Eq Read Show Generic
 
 InterfaceLog  
@@ -26,6 +26,13 @@ InterfaceHealth
   interface Text
   subtype   Text Maybe
   write     Bool Maybe
-  hours     Int  
+  hours     Int                   -- negative number: never expires, i.e. if the last entry is a success, this remains indefinitely
   UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique
   deriving Eq Read Show Generic
+
+ProblemLog  
+  time        UTCTime default=now()
+  info        Value                 -- generic JSON Value allows maximum backwards compatibility
+  solved      UTCTime Maybe
+  solver      UserId Maybe          -- User who marked this problem as done
+  deriving Eq Read Show Generic

models/avs.model

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -16,27 +16,19 @@
 UserAvs
   personId        AvsPersonId -- unique identifier for user throughout avs; newtype for Int  
   user            UserId
-  noPerson        Int         default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle
+  noPerson        Int         default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle, redundant since needed for filtering
   lastSynch       UTCTime     default=now()
   lastSynchError  Text Maybe
+  lastPersonInfo  AvsPersonInfo Maybe -- just to discern field changes
+  lastFirmInfo    AvsFirmInfo   Maybe -- just to discern field changes
+  lastCardNo      AvsFullCardNo Maybe -- just to discern changes
   UniqueUserAvsUser user
   UniqueUserAvsId   personId
   deriving Generic Show
 
--- Multiple UserAvsCards per UserAvs is possible and not too uncommon.
--- Purpose of saving cards is to detect external changes in qualifications and postal addresses
--- TODO: This table will be deleted if AVS CR3 SCF-165 is implemented
-UserAvsCard 
-  personId        AvsPersonId    
-  cardNo          AvsFullCardNo  
-  card            AvsDataPersonCard
-  lastSynch       UTCTime
-  -- UniqueAvsCard cardNo -- Note: cardNo is not unique; invalid cardNo may be reissued to different persons
-  deriving Generic
-
 AvsSync
   user              UserId      -- Note: we need to lookup UserAvs Entity anyway, so no benefit from storing AvsPersonId here
   creationTime      UTCTime
-  pause             Day Maybe
+  pause             Day Maybe   -- Don't synch if last synch after this day, otherwise synch
   UniqueAvsSyncUser user
-  deriving Generic
+  deriving Generic Show

models/company.model

@@ -1,25 +1,18 @@
--- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 -- Description of companies associated with users
 
 Company  
-  name            CompanyName             -- == (CI Text)
+  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    FUTURE TODO: a shorthand will become available through the AVS interface in the future
+  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
+  avsId           Int     default=0       -- primary key from avs, use negative numbers for non-AVS companies 
-  prefersPostal   Bool    default=false   -- new company users prefers letters by post instead of email
+  prefersPostal   Bool    default=true    -- new company users prefers letters by post instead of email
-  postAddress     StoredMarkup Maybe      -- default company postal address 
+  postAddress     StoredMarkup Maybe      -- default company postal address, including company name 
   email           UserEmail Maybe         -- Case-insensitive generic company eMail address  
-  UniqueCompanyName name 
+  -- UniqueCompanyName name               -- Should be Unique in AVS, but we do not yet need to enforce it
-  UniqueCompanyShorthand shorthand
+  -- UniqueCompanyShorthand shorthand     -- unnecessary, since it is the primary key already
-  -- UniqueCompanyAvsId avsId             -- should be the case, unclear if enforcing works here, since we cannot query avs by company id
+  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 }
+  Primary shorthand                       -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } 
   deriving Ord Eq Show Generic Binary
-
--- TODO: a way to populate this table (manually)
-CompanySynonym
-  synonym     CompanyName
-  canonical   CompanyShorthand OnDeleteCascade OnUpdateCascade
-  UniqueCompanySynonym synonym
-  deriving Ord Eq Show Generic

models/jobs.model

@@ -20,11 +20,11 @@ CronLastExec
     time                UTCTime -- When was the job executed
     instance            InstanceId -- Which uni2work-instance did the work
     UniqueCronLastExec job
-    deriving Generic
+    deriving Generic Show
 
 TokenBucket
     ident               TokenBucketIdent
     lastValue           Int64
     lastAccess          UTCTime
     Primary             ident
-    deriving Generic
+    deriving Generic Show

models/lms.model

@@ -13,16 +13,18 @@ Qualification
   refreshWithin       CalendarDiffDays Maybe    -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip
   refreshReminder     CalendarDiffDays Maybe    -- send a second notification about renewal within this number of month/days before expiry
   elearningStart      Bool                      -- automatically schedule e-refresher
-  -- elearningOnly       Bool                   -- successful E-learing automatically increases validity. NO!  
+  elearningRenews     Bool default=true         -- successful e-learing automatically increases validity automatically by validDuration
+  elearningLimit      Int Maybe                 -- limit of e-learning attempts, currently only for informative purposes, as it is enforced by LMS only
+  lmsReuses           QualificationId Maybe     -- if set, lms is also included within the given qualification's lms, but only for direct routes. AuditDuration is used from this Qualification instead.
   expiryNotification  Bool default=true         -- should expiryNotification be generated for this qualification?
   avsLicence          AvsLicence Maybe          -- if set, valid QualificationUsers are synchronized to AVS as a driving licence
   sapId               Text Maybe                -- if set, valid QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id  
   SchoolQualificationShort school shorthand            -- must be unique per school and shorthand
   SchoolQualificationName  school name                 -- must be unique per school and name
-  -- across all schools, only one qualification may be a driving licence:
+    -- across all schools, only one qualification may be a driving licence -- NO LONGER TRUE
-  UniqueQualificationAvsLicence avsLicence      !force -- either empty or unique
+    -- UniqueQualificationAvsLicence avsLicence      !force -- either empty or unique 
     -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
-  deriving Eq Generic
+  deriving Show Eq Generic
 
 -- TODOs:
 --  - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen?
@@ -41,27 +43,27 @@ Qualification
 --  - Flag "interner Mitarbeiter" wird von Know-How ignoriert / nicht ausgewertet (legacy)
 
 -- QualificationPrecondition                       -- NOTE: this can only be enforced through a background job adding or removing qualifications
---   qualification     QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions
+--  qualification     QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions
---   required          [QualificationId]           -- OR : alternatives, any one will suffice
+--  required          [QualificationId]           -- OR : alternatives, any one will suffice -- we don't want array, since we have recursive CTEs
---   continuous        Bool                        -- expiring precondition blocks qualification
+--  continuous        Bool                        -- expiring precondition blocks qualification
---   deriving Generic
+--  deriving Generic Show
 
 -- Maybe an alternative for online qualification validity checking, transitivity through recursive CTEs? (already available in our version)
---QualificationRequirement
+QualificationRequirement
---   qualification     QualificationId OnDeleteCascade OnUpdateCascade
+ qualification     QualificationId OnDeleteCascade OnUpdateCascade
---   requirement       QualificationId OnDeleteCascade OnUpdateCascade
+ requirement       QualificationId OnDeleteCascade OnUpdateCascade
---   group             Text -- OR: several requirements within the same group are considered equivalent
+ group             Int        -- OR: several requirements within the same group are considered equivalent; no order between groups
---   UniqueQualificationRequirement qualification requirement
+ note              Text       -- for humans only, no semantical effect
---   deriving Generic
+ UniqueQualificationRequirement qualification requirement
---
+ deriving Generic Show
 
--- TODO: connect Qualifications with Exams!?
+-- TODO: connect Qualification with Exams!
 
 QualificationEdit
   user            UserId
   time            UTCTime
   qualification   QualificationId OnDeleteCascade OnUpdateCascade
-  deriving Generic
+  deriving Generic Show
 
 QualificationUser
   user              UserId OnDeleteCascade OnUpdateCascade
@@ -70,11 +72,11 @@ QualificationUser
   lastRefresh       Day                           -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False
   firstHeld         Day                           -- first time the qualification was earned, should never change
   scheduleRenewal   Bool  default=true            -- if false, no automatic renewal is scheduled and the qualification expires
-  lastNotified      UTCTime default=now()         -- last notficiation about being invalid
+  lastNotified      UTCTime default=now()         -- last notficiation about actual licence validity changes (does not entail e-learning notifications)
   -- Reasons and temporary revocations are implemented through QualificationUserBlock
   -- TODO: adjust SAP interface to transmit end dates
   UniqueQualificationUser qualification user
-  deriving Generic
+  deriving Generic Show
 
 QualificationUserBlock
   qualificationUser QualificationUserId OnDeleteCascade OnUpdateCascade
@@ -82,7 +84,6 @@ QualificationUserBlock
   from              UTCTime  
   reason            Text  
   blocker           UserId Maybe
-  -- precondition      Bool  default=false  -- if true, this was due to a precondition
   deriving Eq Ord Read Show Generic
 
   -- LMS Interface Tables, need regular processing by background jobs, per QualificationId:
@@ -132,7 +133,7 @@ LmsUser
   -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? No.
   UniqueLmsIdent ident                            -- idents must be unique accross all qualifications, since idents are global within LMS!
   UniqueLmsQualificationUser qualification user   -- each user may be enrolled at most once per course
-  deriving Generic
+  deriving Generic Show
 
 -- LmsUserStatus
 --   lmsUser LmsUserId OnDeleteCascade OnUpdateCascade
@@ -150,7 +151,7 @@ LmsReport
   lock              Bool            -- (0|1)
   timestamp         UTCTime         default=now()
   UniqueLmsReport qualification ident -- required by DBTable
-  deriving Generic
+  deriving Generic Show
 
 -- LmsAudit removed by commit 71cde92a
 -- due to frequent transmit errors, a separate lms tranmission log is necessary again
@@ -162,4 +163,4 @@ LmsReportLog
   lock              Bool            -- (0|1)
   timestamp         UTCTime         default=now()  
   missing           Bool            default=false
-  deriving Generic
+  deriving Generic Show

models/print.model

@@ -10,22 +10,23 @@ PrintJob
   created         UTCTime
   acknowledged    UTCTime Maybe
   recipient       UserId Maybe          OnDeleteSetNull OnUpdateCascade   -- optional as some letters may contain just an address
+  affected        UserId Maybe          OnDeleteSetNull OnUpdateCascade   -- subject of the letter
   sender          UserId Maybe          OnDeleteSetNull OnUpdateCascade   -- senders and associations are optional
   course          CourseId Maybe        OnDeleteCascade OnUpdateCascade
   qualification   QualificationId Maybe OnDeleteCascade OnUpdateCascade
   lmsUser         LmsIdent        Maybe OnDeleteSetNull OnUpdateCascade   -- allows tracking if recipient has been notified; must be unique  
   -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible!
   -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used
-  deriving Generic
+  deriving Generic Show
 
 PrintAcknowledge -- just to store acknowledging requests to be evaluated by a background job later on
   apcIdent        Text
   timestamp       UTCTime         default=now()
   processed       Bool
-  deriving Generic
+  deriving Generic Show
 
 PrintAckIdAlias
   needle          Text
   replacement     Text  
   priority        Int
-  deriving Generic
+  deriving Generic Show

models/users.model

@@ -1,8 +1,8 @@
--- 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@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 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
 
--- The files in /models determine the database scheme.
+-- The files in /models determine t he database scheme.
 -- The organisational split into several files has no operational effects.
 -- White-space and case matters: Each SQL table is named in 1st column of this file
 -- Indendent lower-case lines describe the SQL-columns of the table with name, type and options
@@ -11,16 +11,17 @@
 -- Indendent upper-case lines usually impose Uniqueness constraints for rows by some columns.
 -- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname
 --
-
 User json    -- Each Uni2work user has a corresponding row in this table; created upon first login.
-    ident          UserIdent                -- Case-insensitive user-identifier
-    passwordHash   Text Maybe               -- If specified, allows the user to login with credentials independently of external authentication
-    lastAuthentication UTCTime Maybe        -- When did the user last authenticate?
     surname        UserSurname              -- Display user names always through 'nameWidget displayName surname'
     displayName    UserDisplayName
-    displayEmail   UserEmail
+    displayEmail   UserEmail                -- Case-insensitive eMail address, used for sending; leave empty for using auto-update CompanyEmail via UserCompany
-    email          UserEmail                -- Case-insensitive eMail address, used for sending  TODO: make this nullable
+    email          UserEmail                -- Case-insensitive eMail address, used for identification and fallback for sending. Defaults to "AVSNO:dddddddd" if unknown
+    ident          UserIdent                -- Case-insensitive user-identifier. Defaults to "AVSID:dddddddd" if unknown
+    authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
+    lastAuthentication UTCTime Maybe        -- last login date
     created        UTCTime default=now()
+    lastLdapSynchronisation UTCTime Maybe
+    ldapPrimaryKey UserEduPersonPrincipalName Maybe   -- Fraport Personnel Number or Email-Prefix for @fraport.de work here
     tokensIssuedAfter  UTCTime Maybe        -- do not accept bearer tokens issued before this time (accept all tokens if null)
     matrikelnummer UserMatriculation Maybe  -- usually a number; AVS Personalnummer; nicht Fraport Personalnummer!
     firstName      Text                     -- For export in tables, pre-split firstName from displayName
@@ -43,67 +44,64 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     mobile         Text Maybe
     companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP 
     companyDepartment     Text Maybe -- thus we store such information for ease of reference directly, if available 
-    pinPassword           Text Maybe -- used to encrypt pins within emails
+    pinPassword           Text Maybe -- used to encrypt pins within emails, defaults to cardno.version
-    postAddress           StoredMarkup Maybe 
+    postAddress           StoredMarkup Maybe    -- including company name, if any, but excluding username; leave empty for using auto-update CompanyPostAddress via UserCompany
-    postLastUpdate        UTCTime Maybe -- record postal address updates
+    postLastUpdate        UTCTime Maybe         -- record postal address updates
     prefersPostal         Bool default=false    -- user prefers letters by post instead of email
     examOfficeGetSynced   Bool default=true     -- whether synced status should be displayed for exam results by default
     examOfficeGetLabels   Bool default=true     -- whether labels should be displayed for exam results by default
-    lastSync              UTCTime Maybe         -- When was the User data last synchronised with external sources?
+    UniqueAuthentication ident                  -- Column 'ident' can be used as a row-key in this table
-    UniqueAuthentication  ident                 -- Column 'ident' can be used as a row-key in this table
     UniqueEmail email                           -- Column 'email' can be used as a row-key in this table
+    UniqueLdapPrimaryKey ldapPrimaryKey !force  -- Column 'ldapPrimaryKey' is either empty or contains a unique value
     deriving Show Eq Ord Generic                -- Haskell-specific settings for runtime-value representing a row in memory
 
--- | User data fetched from external user sources, used for authentication and data queries
-ExternalUser
-    user      UserIdent
-    source    AuthSourceIdent              -- Identifier of the external source in the config
-    data      Value "default='{}'::jsonb"  -- Raw user data from external source -- TODO: maybe make Maybe, iff the source only ever responds with "success"?
-    lastSync  UTCTime                      -- When was the external source last queried?
-    UniqueExternalUser user source         -- At most one entry of this user per source
-    deriving Show Eq Ord Generic
-
 UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...)
     user     UserId
     school   SchoolId
     function SchoolFunction
     UniqueUserFunction user school function
     deriving Generic
-UserSystemFunction
+UserSystemFunction Show
     user     UserId
     function SystemFunction   -- Defined in Model.Types.User
     manual   Bool             -- Inserted manually by Admin or automatic from LDAP
     isOptOut Bool             -- User has currently deactivate the role for themselves
     UniqueUserSystemFunction user function
-    deriving Generic
+    deriving Generic Show
 UserExamOffice
     user      UserId
     field     StudyTermsId
     UniqueUserExamOffice user field
-    deriving Generic
+    deriving Generic Show
 UserSchool -- Managed by users themselves, encodes "schools of interest"
     user     UserId
     school   SchoolId
     isOptOut Bool     -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically 
     UniqueUserSchool user school
-    deriving Generic
+    deriving Generic Show
 UserGroupMember
     group         UserGroupName
     user          UserId
     primary       Checkmark nullable
     UniquePrimaryUserGroupMember group primary !force
     UniqueUserGroupMember group user
-    deriving Generic
+    deriving Generic Show
 UserCompany 
     user                  UserId  
     company               CompanyId  OnDeleteCascade OnUpdateCascade
     supervisor            Bool       default=false -- should this user be made supervisor for all _new_ users associated with this company?        
     supervisorReroute     Bool       default=false -- if supervisor is true, should this supervisor receive email for _new_ company users?
+    priority              Int        default=0     -- higher number, higher priority; default=1 for Haskell-Code
+    useCompanyAddress     Bool       default=true  -- if true, CompanyPostalAddress and CompanyEmail are used if UserPostalAddress/UserDisplayEmail are Nothing, respects priority
+    reason                Text Maybe -- miscellaneous note, e.g. Superior
     UniqueUserCompany user company   -- a user may belong to multiple companies, but to each one only once
-    deriving Generic
+    deriving Generic Show
 UserSupervisor
-    supervisor            UserId -- multiple supervisor per trainee possible
+    supervisor            UserId          -- multiple supervisor per trainee possible
     user                  UserId
-    rerouteNotifications  Bool   -- User can be his own supervisor to receive notifications as well
+    rerouteNotifications  Bool            -- User can be his own supervisor to receive notifications as well
-    UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once)
+    company               CompanyId Maybe OnDeleteCascade OnUpdateCascade -- this supervisor was company default supervisor at time of entry
-    deriving Generic
+    reason                Text      Maybe -- miscellaneous reason, e.g. Winterservice supervisision
+    UniqueUserSupervisor supervisor user  -- each supervisor/user combination is unique (same supervisor can superviser the same user only once)
+    deriving Generic Show
+    

nix/docker/default.nix

@@ -14,8 +14,8 @@ let
       '');
     in if self ? lastModified then fromDate else "1970-01-01T00:00:01Z";
 
-  mkUniworxDocker = { scope, isTest }: prev.dockerTools.buildImage {
+  mkUniworxDocker = { isTest }: prev.dockerTools.buildImage {
-    name = "uniworx" + (if scope == null then "" else "-${scope}");
+    name = "uniworx${optionalString isTest "-test"}";
     tag =
       let
         versionFile = if isTest then ./test-version.json else ./version.json;
@@ -31,11 +31,12 @@ let
       busybox # should provide a working lpr -- to be tested
       htop
       pdftk # for encrypting pdfs
+      roboto roboto-mono
       #texlive.combined.scheme-medium # too large for container in LMU build environment.
       (texlive.combine {
           inherit (texlive) scheme-basic
             babel-german babel-english booktabs textpos
-            enumitem eurosym koma-script parskip xcolor dejavu
+            enumitem eurosym koma-script parskip xcolor roboto xkeyval
             # required fro LuaTeX
             luatexbase lualatex-math unicode-math selnolig
             ;
@@ -111,7 +112,6 @@ let
   };
 in
 mapAttrs (_name: mkUniworxDocker) {
-  uniworxDocker = { isTest = false; scope = null; };
+  uniworxTestDocker = { isTest = true; };
-  uniworxTestDocker = { isTest = false; scope = "test"; };
+  uniworxDocker = { isTest = false; };
-  uniworxDevDocker = { isTest = false; scope = "dev"; };
 }

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "28.1.1"
+  "version": "27.4.79"
 }

nix/frontend/node-packages.nix

@@ -1264,6 +1264,15 @@ let
         sha512 = "UWW0TMTmk2d7hLcWD1/e2g5HDM/HQ3csaLSqXCfqwh4uNDuNqlaKWXmEsL4Cs41Z0KnILNvwbHAah3C2yt06kw==";
       };
     };
+    "@fortawesome/fontawesome-pro-6.1.1" = {
+      name = "_at_fortawesome_slash_fontawesome-pro";
+      packageName = "@fortawesome/fontawesome-pro";
+      version = "6.1.1";
+      src = fetchurlBoot {
+        url = "https://npm.fontawesome.com/@fortawesome/fontawesome-pro/-/6.1.1/fontawesome-pro-6.1.1.tgz";
+        hash = "sha256-Pq+n8YWCwwQ9B1Etfqs5sypghBMPWPAJFQ49UAlnS18=";
+      };
+    };
     "@humanwhocodes/config-array-0.9.5" = {
       name = "_at_humanwhocodes_slash_config-array";
       packageName = "@humanwhocodes/config-array";
@@ -10329,6 +10338,7 @@ let
           sources."strip-json-comments-3.1.1"
         ];
       })
+      sources."@fortawesome/fontawesome-pro-6.1.1"
       (sources."@humanwhocodes/config-array-0.9.5" // {
         dependencies = [
           sources."brace-expansion-1.1.11"

nix/uniworx/backend.nix

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor@kleen.consulting>, Steffen Jost <jost@cip.ifi.lmu.de>
+# SPDX-FileCopyrightText: 2022-2023 Gregor Kleen <gregor@kleen.consulting>, Steffen Jost <jost@cip.ifi.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -7,7 +7,7 @@
 with prev.lib;
 
 let
-  haskellInputs = ["encoding" "memcached-binary" "conduit-resumablesink" "HaskellNet-SSL" "ldap-client" "serversession" "xss-sanitize" "colonnade" "minio-hs" "cryptoids" "zip-stream" "yesod" "cryptonite" "esqueleto" "yesod-auth-oauth2"];
+  haskellInputs = ["encoding" "memcached-binary" "conduit-resumablesink" "HaskellNet-SSL" "ldap-client" "serversession" "xss-sanitize" "colonnade" "minio-hs" "cryptoids" "zip-stream" "yesod" "cryptonite" "esqueleto"];
 in {
   uniworx = final.haskell-nix.stackProject {
     src = prev.stdenv.mkDerivation {
@@ -22,28 +22,8 @@ in {
       '';
 
       installPhase = ''
-        runHook preInstall
         mkdir -p $out
         cp -pr --reflink=auto ./. $out
-        echo "Hello from installPhase"
-        exit 1
-      '';
-      unpackPhase = ''
-        runHook postUnpack
-      '';
-      postUnpack = ''
-        ${final.xorg.lndir}/bin/lndir -silent ${prev.uniworxFrontend} $sourceRoot
-        chmod -R a+w $sourceRoot
-        echo "Hello from postUnpack"
-        exit 1
-      '';
-      preInstall = ''
-        echo "Hello from preInstall"
-        exit 1
-        export TZDIR=${final.tzdata}/share/zoneinfo
-        ${optionalString (gitRevision != null) ''
-          export GIT_REVISION=${gitRevision}
-        ''}
       '';
     };
     compiler-nix-name = "ghc8104";
@@ -74,13 +54,22 @@ in {
           yesod-form.src = "${inputs.yesod}/yesod-form";
           yesod-auth.src = "${inputs.yesod}/yesod-auth";
           yesod-test.src = "${inputs.yesod}/yesod-test";
-          yesod-auth-oauth2.src = inputs.yesod-auth-oauth2;
           cryptonite.src = inputs.cryptonite;
           esqueleto.src = inputs.esqueleto;
         };
       }
       {
         packages.uniworx = {
+          postUnpack = ''
+            ${final.xorg.lndir}/bin/lndir -silent ${prev.uniworxFrontend} $sourceRoot
+            chmod a+w -R $sourceRoot
+          '';
+          preBuild = ''
+            export TZDIR=${final.tzdata}/share/zoneinfo
+            ${optionalString (gitRevision != null) ''
+              export GIT_REVISION=${gitRevision}
+            ''}
+          '';
           components.library.build-tools = with final.pkgs; [ llvm_9 ];
           components.exes.uniworx.build-tools = with final.pkgs; [ llvm_9 ];
           components.exes.uniworxdb.build-tools = with final.pkgs; [ llvm_9 ];

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "28.1.1",
+  "version": "27.4.79",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {
@@ -1733,6 +1733,12 @@
         }
       }
     },
+    "@fortawesome/fontawesome-pro": {
+      "version": "6.1.1",
+      "resolved": "https://npm.fontawesome.com/@fortawesome/fontawesome-pro/-/6.1.1/fontawesome-pro-6.1.1.tgz",
+      "integrity": "sha512-0w6GM8sCXNpcBLUz4bx61JvjjoCvfEIz5wBz2KjLNw9qk1F2XiUWuifXobvLbwaA7kqPGBRPo3U8Zw7zyaJ9sA==",
+      "dev": true
+    },
     "@humanwhocodes/config-array": {
       "version": "0.9.5",
       "resolved": "https://registry.npmjs.org/@humanwhocodes/config-array/-/config-array-0.9.5.tgz",

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "28.1.1",
+  "version": "27.4.79",
   "description": "",
   "keywords": [],
   "author": "",
@@ -25,9 +25,7 @@
     "i18n:test": "./missing-translations.sh",
     "prerelease": "./is-clean.sh && npm run test",
     "release": "./release.sh",
-    "release-dev": "./release.sh --dev",
     "postrelease": "git push --follow-tags",
-    "postrelease-dev": "git push --follow-tags",
     "parse-changelog": "changelog-parser ./CHANGELOG.md > changelog.json"
   },
   "husky": {
@@ -57,6 +55,7 @@
     "@babel/preset-env": "^7.18.2",
     "@commitlint/cli": "^17.0.2",
     "@commitlint/config-conventional": "^17.0.2",
+    "@fortawesome/fontawesome-pro": "^6.1.1",
     "autoprefixer": "^10.4.7",
     "babel-core": "^6.26.3",
     "babel-loader": "^8.2.5",

package.yaml

@@ -1,12 +1,11 @@
 name: uniworx
-version: 28.1.1
+version: 27.4.79
 dependencies:
   - base
   - yesod
   - yesod-core
   - yesod-persistent
   - yesod-auth
-  - yesod-auth-oauth2 >=0.7.3.0
   - yesod-static
   - yesod-form
   - yesod-persistent
@@ -21,6 +20,7 @@ dependencies:
   - template-haskell
   - shakespeare
   - monad-control
+  - wai-extra
   - yaml
   - http-conduit
   - directory
@@ -30,6 +30,7 @@ dependencies:
   - conduit
   - monad-logger
   - fast-logger
+  - wai-logger
   - foreign-store
   - file-embed
   - unordered-containers
@@ -38,10 +39,6 @@ dependencies:
   - time
   - case-insensitive
   - wai
-  - wai-cors
-  - wai-extra
-  - wai-logger
-  - wai-middleware-prometheus
   - cryptonite
   - cryptonite-conduit
   - saltine
@@ -146,6 +143,7 @@ dependencies:
   - cookie
   - prometheus-client
   - prometheus-metrics-ghc
+  - wai-middleware-prometheus
   - extended-reals
   - rfc5051
   - unidecode

release.sh

@@ -1,6 +1,6 @@
 #!/usr/bin/env bash
 
-# SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>
+# SPDX-FileCopyrightText: 2023 Sarah Vaupel <sarah.vaupel@uniworx.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -14,12 +14,7 @@ case "$(git rev-parse --abbrev-ref HEAD)" in
     standard-version -a -t t
     ;;
   *)
-    if echo $@ | grep -xqe '--dev';
+    echo "Current branch not supported for release!"
-    then
+    exit 1
-      standard-version -a -t d
-    else
-      echo "Current branch not supported for release!"
-      exit 1
-    fi
     ;;
 esac

routes

@@ -1,4 +1,4 @@
--- 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>,David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2022-24 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-License-Identifier: AGPL-3.0-or-later
 
@@ -30,8 +30,8 @@
 --    !capacity       -- course this route is associated with has at least one unit of participant capacity
 --    !empty          -- course this route is associated with has no participants whatsoever
 --
---    !is-external    -- user can login using external sources
+--    !is-ldap        -- user has authentication mode set to LDAP
---    !is-internal    -- user can login using internal credentials
+--    !is-pw-hash     -- user has authentication mode set to PWHash
 --
 --    !materials      -- only if course allows all materials to be free (no meaning outside of courses)
 --    !time           -- access depends on time somehow
@@ -46,39 +46,43 @@
 /static StaticR EmbeddedStatic appStatic                      !free
 /auth   AuthR   Auth   getAuth                                !free
 
-/logout       SOutR  GET !free
-/logout/ssout SSOutR GET !free -- single sign-out (OIDC)
-
 /metrics     MetricsR GET																			!free -- verify if this can be free
 
 /err                          ErrorR           GET            !free
 
 /                             NewsR            GET            !free
 /users                        UsersR           GET POST       -- no tags, i.e. admins only
-/users/#CryptoUUIDUser        AdminUserR       GET POST
+/users/#CryptoUUIDUser                AdminUserR       GET POST
-/users/#CryptoUUIDUser/delete AdminUserDeleteR     POST
+/users/#CryptoUUIDUser/delete         AdminUserDeleteR     POST
-/users/#CryptoUUIDUser/hijack AdminHijackUserR GET POST       !adminANDno-escalation
+/users/#CryptoUUIDUser/hijack         AdminHijackUserR GET POST       !adminANDno-escalation
 /users/#CryptoUUIDUser/notifications  UserNotificationR           GET POST   !self
 /users/#CryptoUUIDUser/password       UserPasswordR               GET POST   !selfANDis-pw-hash
 !/users/functionary-invite/new        AdminNewFunctionaryInviteR  GET POST
 !/users/functionary-invite            AdminFunctionaryInviteR     GET POST
-!/users/add                   AdminUserAddR      GET POST
+!/users/add                   AdminUserAddR    GET POST
-/admin                        AdminR             GET
+/admin                        AdminR           GET
-/admin/test                   AdminTestR         GET POST
+/admin/test                   AdminTestR       GET POST
-/admin/test/pdf               AdminTestPdfR      GET
+/admin/test/pdf               AdminTestPdfR    GET
-/admin/errMsg                 AdminErrMsgR       GET POST
+/admin/errMsg                 AdminErrMsgR     GET POST
-/admin/tokens                 AdminTokensR       GET POST
+/admin/tokens                 AdminTokensR     GET POST
-/admin/crontab                AdminCrontabR      GET
+/admin/crontab                AdminCrontabR    GET
-/admin/crontab/jobs           AdminJobsR         GET POST
+/admin/crontab/jobs           AdminJobsR       GET POST
-/admin/avs                    AdminAvsR          GET POST
+/admin/avs                    AdminAvsR        GET POST
-/admin/avs/#CryptoUUIDUser    AdminAvsUserR      GET
+/admin/avs/#CryptoUUIDUser    AdminAvsUserR    GET POST
-/admin/external-user          AdminExternalUserR GET POST
+/admin/ldap                   AdminLdapR       GET POST
-/admin/problems               AdminProblemsR     GET
+/admin/problems               AdminProblemsR			 GET POST 
-/admin/problems/no-contact    ProblemUnreachableR  GET
+/admin/problems/no-contact    ProblemUnreachableR  GET POST
 /admin/problems/no-avs-id     ProblemWithoutAvsId  GET
 /admin/problems/r-without-f   ProblemFbutNoR       GET
-/admin/problems/avs           ProblemAvsSynchR     GET POST
+/admin/problems/avs  					ProblemAvsSynchR 		 GET POST
-/admin/problems/avs/errors    ProblemAvsErrorR 	   GET
+/admin/problems/avs/errors		ProblemAvsErrorR 		 GET
+/admin/config/interfaces      ConfigInterfacesR		 GET POST 
+
+/comm                                 CommCenterR     GET 
+/comm/email                           MailCenterR     GET POST
+/comm/email/html/#CryptoUUIDSentMail  MailHtmlR       GET
+/comm/email/plain/#CryptoUUIDSentMail MailPlainR      GET
+/comm/email/attachment/#CryptoUUIDSentMail/#Text MailAttachmentR GET
 
 /print                                PrintCenterR    GET POST  !system-printer
 /print/acknowledge/#Day/#Int/#Int     PrintAckR       GET POST  !system-printer

shell.nix

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor@kleen.consulting>, Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
+# SPDX-FileCopyrightText: 2022-2023 Gregor Kleen <gregor@kleen.consulting>, Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -9,13 +9,6 @@ let
 
   haskellPackages = pkgs.haskellPackages;
 
-  oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=7b995e6cffa963a24eb5d0373b2d29089533284f&ref=main").packages.x86_64-linux;
-
-
-  oauth2MockServer = oauth2Flake.default;
-  mkOauth2DB = oauth2Flake.mkOauth2DB;
-  killOauth2DB = oauth2Flake.killOauth2DB;
-
   postgresSchema = pkgs.writeText "schema.sql" ''
     CREATE USER uniworx WITH SUPERUSER;
     CREATE DATABASE uniworx_test;
@@ -28,17 +21,6 @@ let
     local all all trust
   '';
 
-  oauth2Schema = pkgs.writeText "oauth2_schema.sql" ''
-    CREATE USER oauth2mock WITH SUPERUSER;
-    CREATE DATABASE test_users;
-    GRANT ALL ON DATABASE test_users TO oauth2mock;
-  '';
-
-  oauth2Hba = pkgs.writeText "oauth2_hba_file" ''
-    local all all trust
-  '';
-
-
   develop = pkgs.writeScriptBin "develop" ''
     #!${pkgs.zsh}/bin/zsh -e
 
@@ -62,9 +44,6 @@ let
       type cleanup_cache_memcached &>/dev/null && cleanup_cache_memcached
       type cleanup_minio &>/dev/null && cleanup_minio
       type cleanup_maildev &>/dev/null && cleanup_maildev
-      [[ -z "$OAUTH2_PGDIR" ]] || source ${killOauth2DB}/bin/killOauth2DB
-      [[ -z "$OAUTH2_PGHOST" ]] || pkill oauth2-mock-ser
-      [[ -z "$PORT_OFFSET" ]] || runghc .ports/assign.hs --remove $PORT_OFFSET
 
       [ -f "''${basePath}/.develop.env" ] && rm -vf "''${basePath}/.develop.env"
       set +x
@@ -72,17 +51,7 @@ let
 
     trap cleanup EXIT
 
-    export PORT_OFFSET=$(runghc .ports/assign.hs --assign .ports/offsets)
+    export PORT_OFFSET=$(((16#$(sha256sum <<<"$(hostname -f):''${basePath}" | head -c 16)) % 1000))
-    # export PORT_OFFSET=$(((16#$(sha256sum <<<"$(hostname -f):''${basePath}" | head -c 16)) % 1000))
-
-    if [[ -z "$OAUTH2_PGHOST" ]]; then
-      set -xe
-      export OAUTH2_SERVER_PORT=$((9443 + $PORT_OFFSET))
-      export OAUTH2_DB_PORT=$((9444 + $PORT_OFFSET))
-      source ${mkOauth2DB}/bin/mkOauth2DB
-      ${oauth2MockServer}/bin/oauth2-mock-server&
-      set +xe
-    fi
 
     if [[ -z "$PGHOST" ]]; then
       set -xe
@@ -228,9 +197,9 @@ let
     UPLOAD_S3_KEY_ID=''${MINIO_ACCESS_KEY}
     UPLOAD_S3_KEY=''${MINIO_SECRET_KEY}
 
-    SMTPHOST=''${SMTPHOST}
+    # SMTPHOST=''${SMTPHOST}
-    SMTPPORT=''${SMTPPORT}
+    # SMTPPORT=''${SMTPPORT}
-    SMTPSSL=''${SMTPSSL}
+    # SMTPSSL=''${SMTPSSL}
     EOF
 
     set +xe
@@ -302,9 +271,6 @@ in pkgs.mkShell {
 
     export CHROME_BIN=${pkgs.chromium}/bin/chromium
   '';
-  OAUTH2_HBA = oauth2Hba;
-  OAUTH2_DB_SCHEMA = oauth2Schema;
-  OAUTH2_TEST_USERS = ./test/Database/test-users.yaml;
   nativeBuildInputs = [develop inDevelop killallUni2work diffRunning]
   ++ (with pkgs;
     [ stack nodejs-14_x postgresql_12 openldap exiftool memcached minio minio-client
@@ -313,13 +279,14 @@ in pkgs.mkShell {
       # busybox # for print services, but interferes with build commands in develop-shell
       htop
       pdftk # pdftk just for testing pdf-passwords
+      roboto roboto-mono
       # texlive.combined.scheme-full # works
       # texlive.combined.scheme-medium
       # texlive.combined.scheme-small
       (texlive.combine {
         inherit (texlive) scheme-basic
         babel-german babel-english booktabs textpos
-        enumitem eurosym koma-script parskip xcolor dejavu
+        enumitem eurosym koma-script parskip xcolor roboto xkeyval
         luatexbase lualatex-math unicode-math selnolig # required for LuaTeX
         ;
       })

src/Application.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -6,8 +6,10 @@
 
 module Application
     ( getAppSettings, getAppDevSettings
-    , appMain, develMain
+    , appMain
+    , develMain
     , makeFoundation
+    , makeMiddleware
     -- * for DevelMain
     , foundationStoreNum
     , getApplicationRepl
@@ -18,98 +20,111 @@ module Application
     , addPWEntry
     ) where
 
-import Import hiding (cancel, respond)
+import Control.Monad.Logger                 (liftLoc, LoggingT(..), MonadLoggerIO(..))
-
-import Handler.Utils (runAppLoggingT)
-import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
-
-import Jobs
-
-import Middleware
-
-import Utils.Avs
-import qualified Utils.Pool as Custom
-import Utils.Postgresql
-
-
-import Control.Concurrent.STM.Delay
-import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..))
-import Control.Monad.Trans.Cont (runContT, callCC)
-import Control.Monad.Trans.Resource
-
-import qualified Data.Acid.Memory as Acid
-import qualified Data.Aeson as Aeson
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.IntervalMap.Strict as IntervalMap
-import qualified Data.Map as Map
-import Data.Ratio ((%))
-import qualified Data.Set as Set
-import Data.Streaming.Network (bindPortTCP)
-import qualified Data.Text.Encoding as Text
-import qualified Data.UUID as UUID
-import qualified Data.UUID.V4 as UUID
-
-import qualified Database.Memcached.Binary.IO as Memcached
 import Database.Persist.Postgresql          ( openSimpleConn, pgConnStr, pgPoolIdleTimeout
                                             , pgPoolSize
                                             )
 import Database.Persist.SqlBackend.Internal ( connClose )
 import qualified Database.PostgreSQL.Simple as PG
+import Import                        hiding (cancel, respond)
+import Language.Haskell.TH.Syntax           (qLocation)
+import Network.Wai (Middleware)
+import qualified Network.Wai as Wai
+import Network.Wai.Handler.Warp             (Settings, defaultSettings,
+                                             defaultShouldDisplayException,
+                                             runSettings, runSettingsSocket, setHost,
+                                             setBeforeMainLoop,
+                                             setOnException, setPort, getPort)
+import Network.Connection (settingDisableCertificateValidation)
+import Data.Streaming.Network               (bindPortTCP)
+import Network.Wai.Middleware.RequestLogger (Destination (Logger),
+                                             IPAddrSource (..),
+                                             OutputFormat (..), destination,
+                                             mkRequestLogger, outputFormat)
+import System.Log.FastLogger                ( defaultBufSize, newStderrLoggerSet, newStdoutLoggerSet, newFileLoggerSet
+                                            , toLogStr, rmLoggerSet
+                                            )
+
+import Handler.Utils                        (runAppLoggingT)
 
 import Foreign.Store
 
-import GHC.RTS.Flags (getRTSFlags)
+import Web.Cookie
+import Network.HTTP.Types.Header (hSetCookie)
 
-import Language.Haskell.TH.Syntax (qLocation)
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
 
-import qualified Ldap.Client as Ldap (Host(Plain,Tls))
+import System.Directory
+
+import Jobs
+
+import qualified Data.Text.Encoding as Text
+
+import Yesod.Auth.Util.PasswordStore
+
+import qualified Data.ByteString.Lazy as LBS
 
-import Network.Connection (settingDisableCertificateValidation)
 import Network.HaskellNet.SSL hiding (Settings)
 import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings)
-import Network.HTTP.Client.TLS (mkManagerSettings)
-import qualified Network.Minio as Minio
-import Network.Socket (socketPort, Socket, PortNumber)
-import qualified Network.Socket as Socket (close)
-import Network.Wai.Handler.Warp ( Settings
-                                , defaultSettings
-                                , defaultShouldDisplayException
-                                , runSettings, runSettingsSocket
-                                , getPort, setPort
-                                , setHost, setBeforeMainLoop, setOnException
-                                )
-
-import qualified Prometheus
-
-import qualified System.Clock as Clock
-import System.Directory
-import System.Environment (lookupEnv)
-import System.Exit
-import System.Log.FastLogger ( defaultBufSize
-                             , newStderrLoggerSet, newStdoutLoggerSet, newFileLoggerSet
-                             , toLogStr, rmLoggerSet
-                             )
-import System.Log.FastLogger.Date
-import System.Posix.Process (getProcessID)
-import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM, sigINT)
-import qualified System.Posix.Signals as Signals (Handler(..))
-import qualified System.Systemd.Daemon as Systemd
 
 import UnliftIO.Concurrent
 import UnliftIO.Pool
 
-import qualified Web.ServerSession.Backend.Acid as Acid
+import Control.Monad.Trans.Resource
-import Web.ServerSession.Core (StorageException(..))
 
-import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2Scoped)
+import System.Log.FastLogger.Date
-import Yesod.Auth.Util.PasswordStore
 import qualified Yesod.Core.Types as Yesod (Logger(..))
 
-#ifdef DEVELOPMENT
+import qualified Data.HashMap.Strict as HashMap
-import Data.Maybe (fromJust)
-import Auth.OAuth2 (azureMockServer)
-#endif
 
+import qualified Data.Aeson as Aeson
+
+import System.Exit
+
+import qualified Database.Memcached.Binary.IO as Memcached
+
+import qualified System.Systemd.Daemon as Systemd
+import System.Environment (lookupEnv)
+import System.Posix.Process (getProcessID)
+import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM, sigINT)
+import qualified System.Posix.Signals as Signals (Handler(..))
+
+import Network.Socket (socketPort, Socket, PortNumber)
+import qualified Network.Socket as Socket (close)
+
+import Control.Concurrent.STM.Delay
+import Control.Monad.Trans.Cont (runContT, callCC)
+
+import Data.Ratio ((%))
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import Handler.Utils.Routes (classifyHandler)
+
+import qualified Data.Acid.Memory as Acid
+import qualified Web.ServerSession.Backend.Acid as Acid
+
+import qualified Ldap.Client as Ldap (Host(Plain, Tls))
+
+import qualified Network.Minio as Minio
+
+import Web.ServerSession.Core (StorageException(..))
+
+import GHC.RTS.Flags (getRTSFlags)
+
+import qualified Prometheus
+
+import qualified Data.IntervalMap.Strict as IntervalMap
+
+import qualified Utils.Pool as Custom
+
+import Utils.Postgresql
+import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
+
+import qualified System.Clock as Clock
+
+import Utils.Avs (mkAvsQuery)
 
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
@@ -142,15 +157,17 @@ import Handler.Upload
 import Handler.Qualification
 import Handler.LMS
 import Handler.SAP
+import Handler.CommCenter
+import Handler.MailCenter
 import Handler.PrintCenter
 import Handler.ApiDocs
 import Handler.Swagger
 import Handler.Firm
-import Handler.SingleSignOut
 
 import ServantApi () -- YesodSubDispatch instances
 import Servant.API
 import Servant.Client
+import Network.HTTP.Client.TLS (mkManagerSettings)
 
 
 -- This line actually creates our YesodDispatch instance. It is the second half
@@ -221,7 +238,7 @@ makeFoundation appSettings''@AppSettings{..} = do
     -- from there, and then create the real foundation.
     let
       mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _
-      mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..}
+      mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..}
       tempFoundation = mkFoundation
         (error "appSettings' forced in tempFoundation")
         (error "connPool forced in tempFoundation")
@@ -238,12 +255,10 @@ makeFoundation appSettings''@AppSettings{..} = do
         (error "MinioConn forced in tempFoundation")
         (error "VerpSecret forced in tempFoundation")
         (error "AuthKey forced in tempFoundation")
-        (error "AuthPlugins forced in tempFoundation")
         (error "PersonalisedSheetFilesSeedKey forced in tempFoundation")
         (error "VolatileClusterSettingsCache forced in tempFoundation")
         (error "AvsQuery forced in tempFoundation")
 
-      
     runAppLoggingT tempFoundation $ do
       $logInfoS "InstanceID" $ UUID.toText appInstanceID
       $logInfoS "Configuration" $ tshowCrop appSettings''
@@ -278,32 +293,13 @@ makeFoundation appSettings''@AppSettings{..} = do
           sqlPool = Custom.hoistPool (liftIO . flip runLoggingT logFunc) sqlPool'
       void . Prometheus.register . poolMetrics PoolDatabaseConnections $ sqlPool @IO
 
-      -- ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appUserDbConf $ \conf -> if
+      ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
-      --   | UserDbSingleSource{..} <- conf
+        let ldapLabel = case ldapHost of
-      --   , UserDbLdap LdapConf{..} <- userdbSingleSource
+              Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
-      --   , Just ResourcePoolConf{..} <- userdbPoolConf
+              Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
-      --     -> do
+        $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
-      --          let ldapLabel = case ldapHost of
+        (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
-      --                Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
+      forM_ ldapPool $ registerFailoverMetrics "ldap"
-      --                Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
-      --          $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
-      --          (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort poolStripes poolTimeout ldapTimeout poolLimit
-      --   | otherwise
-      --     -> return mempty
-      -- forM_ ldapPool $ registerFailoverMetrics "ldap"
-
-      -- TODO: reintroduce failover once UserDbFailover is implemented (see above)
-      ldapPool <- fmap join . forM appLdapPoolConf $ \ResourcePoolConf{..} -> if
-        | UserAuthConfSingleSource{..} <- appUserAuthConf
-        , AuthSourceConfLdap conf@LdapConf{..} <- userAuthConfSingleSource
-          -> do -- set up a singleton ldap pool with no failover
-               let ldapLabel = case ldapConfHost of
-                     Ldap.Plain str -> pack str <> ":" <> tshow ldapConfPort
-                     Ldap.Tls str _ -> pack str <> ":" <> tshow ldapConfPort
-               $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
-               Just . (conf,) <$> createLdapPool ldapConfHost ldapConfPort poolStripes poolTimeout ldapConfTimeout poolLimit
-        | otherwise -- No LDAP pool to be initialized
-          -> return Nothing
 
       -- Perform database migration using our application's logging settings.
       flip runReaderT tempFoundation $
@@ -324,40 +320,6 @@ makeFoundation appSettings''@AppSettings{..} = do
       appAuthKey <- clusterSetting (Proxy :: Proxy 'ClusterAuthKey) `customRunSqlPool` sqlPool
       appPersonalisedSheetFilesSeedKey <- clusterSetting (Proxy :: Proxy 'ClusterPersonalisedSheetFilesSeedKey) `customRunSqlPool` sqlPool
 
-      -- TODO: use scopes from Settings
-#ifdef DEVELOPMENT
-      oauth2Plugins <- liftIO $ sequence
-        [ (azureMockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT"
-        , return $ oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] "42" "42" "shhh"
-        ]
-#else
-      -- let -- Auth Plugins
-        -- loadPlugin p prefix = do -- Loads given YesodAuthPlugin
-        --   mID <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzureAdV2 . _azureConfClientId
-        --   mSecret <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzureAdV2 . _azureConfClientSecret
-        --   let mArgs = (,) <$> mID <*> mSecret
-        --   guard $ isJust mArgs
-        --   return . uncurry p $ fromJust mArgs
-        -- tenantID = case appUserAuthConf of
-        --   UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..})
-        --     -> tshow azureConfTenantId
-        --   _other
-        --     -> error "Tenant ID missing!"
-      oauth2Plugins <- if
-        | UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..}) <- appUserAuthConf -> do
-          $logInfoS "OAuth2" "Successfully parsed OAuth2 config from AppSettings"
-          return . singleton $ oauth2AzureADv2Scoped (Set.toList azureConfScopes) (tshow azureConfClientId) azureConfClientSecret
-        | otherwise -> do
-          when appSingleSignOn $ do
-            $logErrorS "OAuth2" "SingleSignOn via AzureADv2 is enabled, but user-auth config could not be parsed!"
-            when appAutoSignOn $
-              $logErrorS "OAuth2" "SingleSignOn via AzureADv2 and AutoSignOn are enabled, but user-auth config could not be parsed! This will likely prevent the app from being accessible!"
-            $logInfoS "UserAuthConf" $ tshow appUserAuthConf
-          return mempty
-#endif
-      let appAuthPlugins = oauth2Plugins
-
-
       let appVolatileClusterSettingsCacheTime' = Clock.fromNanoSecs ns
             where (MkFixed ns :: Nano) = realToFrac appVolatileClusterSettingsCacheTime
       appVolatileClusterSettingsCache <- newTVarIO $ mkVolatileClusterSettingsCache appVolatileClusterSettingsCacheTime'
@@ -417,8 +379,7 @@ makeFoundation appSettings''@AppSettings{..} = do
 
       $logDebugS "Runtime configuration" $ tshowCrop appSettings'
 
-      -- TODO: reimplement user db failover
+      let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
-      let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
 
       -- Return the foundation
       $logInfoS "setup" "*** DONE ***"
@@ -517,6 +478,66 @@ createMemcached MemcachedConf{memcachedConnectInfo} = snd <$> allocate (Memcache
 makeApplication :: MonadIO m => UniWorX -> m Application
 makeApplication foundation = liftIO $ makeMiddleware foundation <*> toWaiAppPlain foundation
 
+makeMiddleware :: MonadIO m => UniWorX -> m Middleware
+makeMiddleware app = do
+  logWare <- makeLogWare
+  return $ observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies . defaultMiddlewaresNoLogging
+  where
+    makeLogWare = do
+      logWareMap <- liftIO $ newTVarIO HashMap.empty
+
+      let
+        mkLogWare ls@LogSettings{..} = do
+          logger <- readTVarIO . snd $ appLogger app
+          logWare <- mkRequestLogger def
+            { outputFormat = bool
+                (Apache . bool FromSocket FromHeader $ app ^. _appIpFromHeader)
+                (Detailed True)
+                logDetailed
+            , destination = Logger $ loggerSet logger
+            }
+          atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare
+          return logWare
+
+      void. liftIO $
+        mkLogWare =<< readTVarIO (appLogSettings app)
+
+      return $ \wai req fin -> do
+        lookupRes <- atomically $ do
+          ls <- readTVar $ appLogSettings app
+          existing <- HashMap.lookup ls <$> readTVar logWareMap
+          return $ maybe (Left ls) Right existing
+        logWare <- either mkLogWare return lookupRes
+        logWare wai req fin
+
+    normalizeCookies :: Wai.Middleware
+    normalizeCookies waiApp req respond = waiApp req $ \res -> do
+        resHdrs' <- go $ Wai.responseHeaders res
+        respond $ Wai.mapResponseHeaders (const resHdrs') res
+      where parseSetCookie' :: ByteString -> IO (Maybe SetCookie)
+            parseSetCookie' = fmap (either (\(_ :: SomeException) -> Nothing) Just) . try . evaluate . force . parseSetCookie
+
+            go [] = return []
+            go (hdr@(hdrName, hdrValue) : hdrs)
+              | hdrName == hSetCookie = do
+                  mcookieHdr <- parseSetCookie' hdrValue
+                  case mcookieHdr of
+                    Nothing -> (hdr :) <$> go hdrs
+                    Just cookieHdr -> do
+                      let cookieHdrMatches hdrValue' = maybeT (return False) $ do
+                            cookieHdr' <- MaybeT $ parseSetCookie' hdrValue'
+                            -- See https://tools.ietf.org/html/rfc6265
+                            guard $ setCookiePath     cookieHdr' == setCookiePath     cookieHdr
+                            guard $ setCookieName     cookieHdr' == setCookieName     cookieHdr
+                            guard $ setCookieDomain   cookieHdr' == setCookieDomain   cookieHdr
+                            return True
+                      others <- filterM (\(hdrName', hdrValue') -> and2M (pure $ hdrName' == hSetCookie) (cookieHdrMatches hdrValue')) hdrs
+                      if | null others -> (hdr :) <$> go hdrs
+                         | otherwise   -> go hdrs
+              | otherwise = (hdr :) <$> go hdrs
+
+
+
 -- | Warp settings for the given foundation value.
 warpSettings :: UniWorX -> Settings
 warpSettings foundation = defaultSettings
@@ -597,8 +618,6 @@ appMain = runResourceT $ do
     foundation <- makeFoundation settings
 
     runAppLoggingT foundation $ do
-      $logDebugS "AppSettings" $ tshow settings
-
       $logInfoS "setup" "Job-Handling"
       handleJobs foundation
 
@@ -715,7 +734,7 @@ shutdownApp app = do
   liftIO $ do
     Custom.purgePool $ appConnPool app
     for_ (appSmtpPool app) destroyAllResources
-    for_ (appLdapPool app) $ views _2 destroyAllResources
+    for_ (appLdapPool app) . mapFailover $ views _2 destroyAllResources
     for_ (appWidgetMemcached app) Memcached.close
     for_ (appMemcached app) $ views _memcachedConn Memcached.close
   release . fst $ appLogger app
@@ -729,8 +748,8 @@ shutdownApp app = do
 
 -- | Run a handler
 handler, handler' :: Handler a -> IO a
-handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
+handler  h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
-handler' h = runResourceT $ getAppSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
+handler' h = runResourceT $ getAppSettings    >>= makeFoundation >>= liftIO . flip unsafeHandler h
 
 -- | Run DB queries
 db, db' :: DB a -> IO a
@@ -740,7 +759,7 @@ db' = handler' . runDB
 addPWEntry :: User
            -> Text {-^ Password -}
            -> IO ()
-addPWEntry User{ userPasswordHash = _, ..} (Text.encodeUtf8 -> pw) = db' $ do
+addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do
   PWHashConf{..} <- getsYesod $ view _appAuthPWHash
-  (Just . Text.decodeUtf8 -> userPasswordHash) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
+  (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
   void $ insert User{..}

src/Audit.hs

@@ -1,7 +1,9 @@
--- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# LANGUAGE TypeApplications #-}
+
 module Audit
   ( module Audit.Types
   , AuditException(..)
@@ -9,6 +11,7 @@ module Audit
   , AuditRemoteException(..)
   , getRemote
   , logInterface, logInterface'
+  , reportAdminProblem
   ) where
 
 
@@ -16,6 +19,8 @@ import Import.NoModel
 import Settings
 import Model
 import Database.Persist.Sql
+import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Utils        as E
 import Audit.Types
 
 import qualified Data.Text          as Text
@@ -152,7 +157,7 @@ logInterface' :: ( AuthId (HandlerSite m) ~ Key User
 -- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
 logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do
   interfaceLogTime  <- liftIO getCurrentTime
-  -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest
+  -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- deleteBy & insert would be justified here, leading to a new Row-ID, since the two rows are not truly connected.
   -- insert_ InterfaceLog{..}
   void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite)
     ( InterfaceLog{..} )
@@ -169,3 +174,28 @@ logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogS
     , transactionInterfaceInfo    = interfaceLogInfo
     , transactionInterfaceSuccess = Just interfaceLogSuccess
     }
+
+reportAdminProblem ::  ( IsSqlBackend (YesodPersistBackend (HandlerSite m))
+                  , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
+                  , MonadHandler m
+                  -- , HasCallStack
+                  )
+      => AdminProblem -- ^ Problem to record
+      -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
+-- ^ Log a problem that needs interventions by admins, provided this problem has not already been reported and is still unsolved
+--
+--   - `problemLogTime` is now
+--   - `problemSolver` is Nothing, we do not record the person who caused it
+reportAdminProblem problem = do
+  let problemLogSolved = Nothing
+      problemLogSolver = Nothing
+      problemLogInfo   = toJSON problem
+  problemLogTime <- liftIO getCurrentTime
+  isKnown <- E.selectExists $ do
+    pl <- E.from $ E.table @ProblemLog
+    E.where_ $ E.isNothing (pl E.^. ProblemLogSolved)
+        E.&&. E.val problemLogInfo E.==. pl E.^. ProblemLogInfo
+  unless isKnown $ insert_ ProblemLog{..}
+  $logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack)
+
+

src/Audit/Types.hs

@@ -1,15 +1,18 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Audit.Types
   ( Transaction(..)
+  , AdminProblem(..)
+  , decodeAdminProblem
   ) where
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
 import Model.Types.TH.JSON
 import Model
 
+import Data.Aeson
 import Data.Aeson.TH
 import Utils.PathPiece
 
@@ -252,3 +255,62 @@ deriveJSON defaultOptions
   } ''Transaction
 
 derivePersistFieldJSON ''Transaction
+
+
+
+-- Datatype for raising admin awareness to certain problems
+-- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries
+-- Note that there is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell dealing with special cases instead
+-- Note: Adjust MsgAdminProblemInfoTooltip as well
+data AdminProblem
+  = AdminProblemNewCompany                                      -- new company was noticed, presumably without supervisors
+    { adminProblemCompany           :: CompanyId
+    }
+  | AdminProblemSupervisorNewCompany
+    { adminProblemUser              :: UserId                   -- a default supervisor has changed company
+    , adminProblemCompany           :: CompanyId                -- old company where the user had default supervisor rights
+    , adminProblemCompanyNew        :: CompanyId                -- new company of the user
+    , adminProblemSupervisorReroute :: Bool                     -- reroute included?
+    }
+  | AdminProblemSupervisorLeftCompany
+    { adminProblemUser              :: UserId                   -- user who had a supervisor but no longer has, due to supervisor change
+    , adminProblemCompany           :: CompanyId                -- old company
+    , adminProblemSupervisorReroute :: Bool                     -- reroute included?
+    }
+  | AdminProblemCompanySuperiorChange                           -- a company received a new superior user through AVS
+    { adminProblemUser              :: UserId                   -- new superior user
+    , adminProblemCompany           :: CompanyId                -- affected company
+    , adminProblemUserOld           :: Maybe UserId             -- previous superior
+    }
+  | AdminProblemCompanySuperiorNotFound                         -- a company received a new superior user through AVS, but user could not be created from email
+    { adminProblemEmail             :: Maybe Text               -- new superior user's email, not found in LDAP
+    , adminProblemCompany           :: CompanyId                -- affected company
+    , adminProblemUserOld           :: Maybe UserId             -- previous superior
+    }
+  | AdminProblemNewlyUnsupervised
+    { adminProblemUser              :: UserId                   -- user who had a supervisor but no longer has, due to user company change
+    , adminProblemCompanyOld        :: Maybe CompanyId          -- old company
+    , adminProblemCompanyNew        :: CompanyId                -- new company of the user
+    }
+  | AdminProblemUnknown                                         -- miscellanous problem, just displaying text
+    { adminProblemText              :: Text
+    }
+  deriving (Eq, Ord, Read, Show, Generic)
+
+-- Columns shown in problem table: adminProblemCompany, adminProblemUser
+-- For display: add clause to Handler.Admin.adminProblemCell
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 2
+  , tagSingleConstructors = True
+  , sumEncoding = TaggedObject "problem" "data"
+  , rejectUnknownFields = False
+  } ''AdminProblem
+
+derivePersistFieldJSON ''AdminProblem
+
+decodeAdminProblem :: Value -> AdminProblem
+decodeAdminProblem v = case fromJSON v of
+  Error msg -> AdminProblemUnknown $ pack msg
+  Success p -> p

src/Auth/Dummy.hs

@@ -34,7 +34,7 @@ dummyForm = do
   mr <- getMessageRender
   wreq (ciField & addDatalist userList) (fslpI MsgDummyIdent (mr MsgDummyIdentPlaceholder) & addAttr "autocomplete" "username" & addName PostLoginDummy) Nothing
   where
-    userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
+    userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [UserId <=. UserKey 12] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
     toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
 
 apDummy :: Text

src/Auth/LDAP.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -7,11 +7,11 @@
 module Auth.LDAP
   ( apLdap
   , ADError(..), ADInvalidCredentials(..)
-  , ldapLogin
+  , campusLogin
-  , LdapUserException(..)
+  , CampusUserException(..)
-  , ldapUser, ldapUser', ldapUser''
+  , campusUser, campusUser', campusUser''
---, ldapUserReTest, ldapUserReTest'
+  , campusUserReTest, campusUserReTest'
-  , ldapUserMatr, ldapUserMatr'
+  , campusUserMatr, campusUserMatr'
   , CampusMessage(..)
   , ldapPrimaryKey
   , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
@@ -20,36 +20,32 @@ module Auth.LDAP
   , ldapUserMobile, ldapUserTelephone
   , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung
   , ldapUserTitle
-  , ldapSearch
   ) where
 
 import Import.NoFoundation
 
-import Auth.LDAP.AD
+import qualified Data.CaseInsensitive as CI
+
+import Utils.Metrics
+import Utils.Form
 
 import qualified Ldap.Client as Ldap
 
-import Utils.Form
-import Utils.Metrics
-
-import qualified Data.CaseInsensitive as CI
 import qualified Data.Text.Encoding as Text
 
 import qualified Yesod.Auth.Message as Msg
 
+import Auth.LDAP.AD
 
--- | Plugin name of the LDAP yesod auth plugin
+-- allow Ldap.Attr usage as key for Data.Map
-apLdap :: Text
+deriving newtype instance Ord Ldap.Attr
-apLdap = "LDAP"
 
 
--- TODO: rename
 data CampusLogin = CampusLogin
   { campusIdent :: CI Text
   , campusPassword :: Text
   } deriving (Generic)
 
--- TODO: rename
 data CampusMessage = MsgCampusIdentPlaceholder
                    | MsgCampusIdent
                    | MsgCampusPassword
@@ -57,12 +53,8 @@ data CampusMessage = MsgCampusIdentPlaceholder
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 
-findUser :: LdapConf 
+findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
-         -> Ldap
+findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
-         -> Text -- ^ needle
-         -> [Ldap.Attr]
-         -> IO [Ldap.SearchEntry]
-findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapConfBase $ userSearchSettings conf) retAttrs) userFilters
   where
     userFilters =
       [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
@@ -77,37 +69,21 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM
       [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident
       ]
 
-findUserMatr :: LdapConf
+findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
-             -> Ldap
+findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
-             -> Text -- ^ matriculation needle
-             -> [Ldap.Attr]
-             -> IO [Ldap.SearchEntry]
-findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapConfBase $ userSearchSettings conf) retAttrs) userFilters
   where
     userFilters =
       [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr
       ]
 
-userSearchSettings :: LdapConf
+userSearchSettings :: LdapConf -> Ldap.Mod Ldap.Search
-                   -> Ldap.Mod Ldap.Search
 userSearchSettings LdapConf{..} = mconcat
-  [ Ldap.scope ldapConfScope
+  [ Ldap.scope ldapScope
   , Ldap.size 2
-  , Ldap.time ldapConfSearchTimeout
+  , Ldap.time ldapSearchTimeout
   , Ldap.derefAliases Ldap.DerefAlways
   ]
 
-ldapSearch :: forall m.
-              ( MonadUnliftIO m
-              , MonadCatch m
-              )
-           => (LdapConf, LdapPool)
-           -> Text -- ^ needle
-           -> m [Ldap.SearchEntry]
-ldapSearch (conf@LdapConf{..}, ldapPool) needle = either (throwM . LdapUserLdapError) return <=< withLdap ldapPool $ \ldap -> liftIO $ do
-  Ldap.bind ldap ldapConfDn ldapConfPassword
-  findUser conf ldap needle []
-
 ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserTitle, ldapUserTelephone,  ldapUserMobile, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung  :: Ldap.Attr
 ldapPrimaryKey            = Ldap.Attr "cn" -- should always be identical to "sAMAccountName"
 ldapUserPrincipalName     = Ldap.Attr "userPrincipalName"
@@ -128,35 +104,30 @@ ldapUserEmail = Ldap.Attr "mail" :|
   ]
 
 
--- TODO: deprecate in favour of FetchUserDataException
+data CampusUserException = CampusUserLdapError LdapPoolError
-data LdapUserException = LdapUserLdapError LdapPoolError
+                         | CampusUserNoResult
-                       | LdapUserNoResult
+                         | CampusUserAmbiguous
-                       | LdapUserAmbiguous
   deriving (Show, Eq, Generic)
 
-instance Exception LdapUserException
+instance Exception CampusUserException
 
-makePrisms ''LdapUserException
+makePrisms ''CampusUserException
 
-
+campusUserWith :: ( MonadUnliftIO m
-ldapUserWith :: ( MonadUnliftIO m
+                  , MonadCatch m
-                , MonadCatch m
+                  )
-              --, MonadLogger m
+               => (    Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
-                )
+                    -> Failover (LdapConf, LdapPool)
-                -- (    Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
+                    -> FailoverMode
-                --     -> (LdapConf, LdapPool)
+                    -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList [])))
-                --     -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList [])))
+                    -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
-                --     -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
+                  )
-                -- )
+               -> Failover (LdapConf, LdapPool)
-             => (    LdapPool
+               -> FailoverMode
-                  -> (Ldap -> m (Either LdapUserException (Ldap.AttrList [])))
+               -> Creds site
-                  -> m (Either LdapPoolError (Either LdapUserException (Ldap.AttrList [])))
+               -> m (Either CampusUserException (Ldap.AttrList []))
-                )
+campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do
-             -> (LdapConf, LdapPool)
+  lift $ Ldap.bind ldap ldapDn ldapPassword
-             -> Creds site
-             -> m (Either LdapUserException (Ldap.AttrList []))
-ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . LdapUserLdapError) return <=< withLdap' pool $ \ldap -> liftIO . runExceptT $ do
-  lift $ Ldap.bind ldap ldapConfDn ldapConfPassword
   results <- case lookup "DN" credsExtra of
     Just userDN -> do
       let userFilter = Ldap.Present ldapUserPrincipalName
@@ -164,91 +135,43 @@ ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . Ld
     Nothing -> do
       lift $ findUser conf ldap credsIdent []
   case results of
-    [] -> throwE LdapUserNoResult
+    [] -> throwE CampusUserNoResult
     [Ldap.SearchEntry _ attrs] -> return attrs
-    _otherwise -> throwE LdapUserAmbiguous
+    _otherwise -> throwE CampusUserAmbiguous
+
+campusUserReTest  :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
+campusUserReTest pool doTest mode creds = throwLeft =<< campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds
+
+campusUserReTest' :: (MonadMask m, MonadLogger m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
+campusUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey}
+  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap upsertIdent [])
+  where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey 
 
 
--- TODO: reintroduce once failover has been reimplemented
+campusUser :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
--- ldapUserReTest  :: ( MonadUnliftIO m
+campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds
---                    , MonadMask m
---                    , MonadLogger m
---                    )
---                 => Failover (LdapConf, LdapPool)
---                 -> (Nano -> Bool)
---                 -> FailoverMode
---                 -> Creds site
---                 -> m (Ldap.AttrList [])
--- ldapUserReTest pool doTest mode creds = throwLeft =<< ldapUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds
--- 
--- ldapUserReTest' :: ( MonadMask m
---                    , MonadLogger m
---                    , MonadUnliftIO m
---                    )
---                 => Failover (LdapConf, LdapPool)
---                 -> (Nano -> Bool)
---                 -> FailoverMode
---                 -> User
---                 -> m (Maybe (Ldap.AttrList []))
--- ldapUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey}
---   = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUserReTest pool doTest mode (Creds apLdap upsertIdent [])
---   where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey 
 
+campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
+campusUser' pool mode User{userIdent}
+  = campusUser'' pool mode $ CI.original userIdent
 
--- TODO: deprecate in favour of fetchUserData
+campusUser'' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Text -> m (Maybe (Ldap.AttrList []))
-ldapUser :: ( MonadMask m
+campusUser'' pool mode ident
-            , MonadUnliftIO m
+  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap ident [])
-          --, MonadLogger m
-            )
-         => (LdapConf, LdapPool)
-         -> Creds site
-         -> m (Ldap.AttrList [])
-ldapUser pool creds = throwLeft =<< ldapUserWith withLdap pool creds
 
-ldapUser' :: ( MonadMask m
+campusUserMatr :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
-             , MonadUnliftIO m
+campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
-           --, MonadLogger m
+  Ldap.bind ldap ldapDn ldapPassword
-             )
-          => (LdapConf, LdapPool)
-          -> User
-          -> m (Maybe (Ldap.AttrList []))
-ldapUser' pool User{userIdent}
-  = ldapUser'' pool $ CI.original userIdent
-
-ldapUser'' :: ( MonadMask m
-              , MonadUnliftIO m
-            --, MonadLogger m
-              )
-           => (LdapConf, LdapPool)
-           -> Text
-           -> m (Maybe (Ldap.AttrList []))
-ldapUser'' pool ident
-  = runMaybeT . catchIfMaybeT (is _LdapUserNoResult) $ ldapUser pool (Creds apLdap ident [])
-
-
-ldapUserMatr :: ( MonadUnliftIO m
-                , MonadMask m
-              --, MonadLogger m
-                )
-             => (LdapConf, LdapPool)
-             -> UserMatriculation
-             -> m (Ldap.AttrList [])
-ldapUserMatr (conf@LdapConf{..}, pool) userMatr = either (throwM . LdapUserLdapError) return <=< withLdap pool $ \ldap -> liftIO $ do
-  Ldap.bind ldap ldapConfDn ldapConfPassword
   results <- findUserMatr conf ldap userMatr []
   case results of
-    [] -> throwM LdapUserNoResult
+    [] -> throwM CampusUserNoResult
     [Ldap.SearchEntry _ attrs] -> return attrs
-    _otherwise -> throwM LdapUserAmbiguous
+    _otherwise -> throwM CampusUserAmbiguous
+
+campusUserMatr' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
+campusUserMatr' pool mode
+  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode
 
-ldapUserMatr' :: ( MonadMask m
-                 , MonadUnliftIO m
-               --, MonadLogger m
-                 )
-              => (LdapConf, LdapPool)
-              -> UserMatriculation
-              -> m (Maybe (Ldap.AttrList []))
-ldapUserMatr' pool = runMaybeT . catchIfMaybeT (is _LdapUserNoResult) . ldapUserMatr pool
 
 
 newtype ADInvalidCredentials = ADInvalidCredentials ADError
@@ -263,28 +186,25 @@ campusForm :: ( RenderMessage (HandlerSite m) FormMessage
               , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
               , RenderMessage (HandlerSite m) CampusMessage
               , MonadHandler m
-              )
+              ) => WForm m (FormResult CampusLogin)
-           => WForm m (FormResult CampusLogin)
 campusForm = do
   MsgRenderer mr <- getMsgRenderer
   aFormToWForm $ CampusLogin
    <$> areq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "" & addAttr "autocomplete" "username") Nothing
    <*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder) & addAttr "autocomplete" "current-password") Nothing
 
+apLdap :: Text
+apLdap = "LDAP"
 
--- TODO: reintroduce Failover
+campusLogin :: forall site.
-ldapLogin :: forall site.
+               ( YesodAuth site
-             ( YesodAuth site
+               , RenderMessage site CampusMessage
-             , RenderMessage site CampusMessage
+               , RenderAFormSite site
-             , RenderAFormSite site
+               , RenderMessage site (ValueRequired site)
-             , RenderMessage site (ValueRequired site)
+               , RenderMessage site ADInvalidCredentials
-             , RenderMessage site ADInvalidCredentials
+               , Button site ButtonSubmit
-             , Button site ButtonSubmit
+               ) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site
-             )
+campusLogin pool mode = AuthPlugin{..}
-          => LdapConf
-          -> LdapPool
-          -> AuthPlugin site
-ldapLogin conf@LdapConf{..} pool = AuthPlugin{..}
   where
     apName :: Text
     apName = apLdap
@@ -295,8 +215,8 @@ ldapLogin conf@LdapConf{..} pool = AuthPlugin{..}
       tp <- getRouteToParent
 
       resp <- formResultMaybe loginRes $ \CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> Just <$> do
-        ldapResult <- withLdap pool $ \ldap -> liftIO $ do
+        ldapResult <- withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
-          Ldap.bind ldap ldapConfDn ldapConfPassword
+          Ldap.bind ldap ldapDn ldapPassword
           searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
           case searchResults of
             [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]

src/Auth/OAuth2.hs

@@ -1,251 +0,0 @@
--- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
-
-module Auth.OAuth2
-  ( apAzure
-  , azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage
-  -- , azureUser, azureUser'
-  , AzureUserException(..), _AzureUserError, _AzureUserNoResult, _AzureUserAmbiguous
-  , apAzureMock
-  , azureMockServer
-  , queryOAuth2User
-  , refreshOAuth2Token
-  , singleSignOut
-  ) where
-
--- import qualified Data.CaseInsensitive as CI
-import Data.Maybe (fromJust)
-import qualified Data.Set as Set
-import Data.Text
-
-import Import.NoFoundation hiding (pack, unpack)
-
-import Network.HTTP.Simple (httpJSONEither, getResponseBody, JSONException)
-
-# ifdef DEVELOPMENT
-import System.Environment (lookupEnv)
-# endif
-
-import Yesod.Auth.OAuth2
-import Yesod.Auth.OAuth2.Prelude hiding (encodeUtf8)
-
--- | Plugin name of the OAuth2 yesod plugin for Azure ADv2
-apAzure :: Text
-apAzure = "AzureADv2"
-
-
--- TODO: deprecate in favour of FetchUserDataException
-data AzureUserException = AzureUserError
-                        | AzureUserNoResult
-                        | AzureUserAmbiguous
-                        deriving (Show, Eq, Generic)
-
-instance Exception AzureUserException
-
-makePrisms ''AzureUserException
-
-
-azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage :: Text
-azurePrimaryKey = "id"
-azureUserPrincipalName = "userPrincipalName"
-azureUserDisplayName = "displayName"
-azureUserGivenName = "givenName"
-azureUserSurname = "surname"
-azureUserMail = "mail"
-azureUserTelephone = "businessPhones"
-azureUserMobile = "mobilePhone"
-azureUserPreferredLanguage = "preferredLanguage"
-
-
--- | User lookup in Microsoft Graph with given credentials
--- TODO: deprecate in favour of fetchUserData
--- azureUser :: ( MonadMask m
---              , MonadHandler m
---              -- , HandlerSite m ~ site
---              -- , BackendCompatible SqlBackend (YesodPersistBackend site)
---              -- , BaseBackend (YesodPersistBackend site) ~ SqlBackend
---              -- , YesodPersist site
---              -- , PersistUniqueWrite (YesodPersistBackend site)
---              )
---              => AzureConf
---              -> Creds site
---              -> m [(Text, [ByteString])] -- (Either AzureUserException [(Text, [ByteString])])
--- azureUser AzureConf{..} Creds{..} = fmap throwLeft . runExceptT $ do
---   now <- liftIO getCurrentTime
---   results <- queryOAuth2User @[(Text, [ByteString])] credsIdent
---   case results of
---     Right [res] -> do
---       -- void . liftHandler . runDB $ upsert ExternalUser
---       --   { externalUserUser     =  error "no userid" -- TODO: use azureUserPrimaryKey once UserIdent is referenced instead of UserId
---       --   , externalUserSource   =  AuthSourceIdAzure azureConfClientId
---       --   , externalUserData     =  toJSON res
---       --   , externalUserLastSync =  now
---       --   }
---       --   [ ExternalUserData     =. toJSON res
---       --   , ExternalUserLastSync =. now
---       --   ]
---       return res
---     Right _multiple -> throwE AzureUserAmbiguous
---     Left _ -> throwE AzureUserNoResult
-
--- | User lookup in Microsoft Graph with given user
--- azureUser' :: ( MonadMask m
---               , MonadHandler m
---               , HandlerSite m ~ site
---               , BaseBackend (YesodPersistBackend site) ~ SqlBackend
---               , YesodPersist site
---               , PersistUniqueWrite (YesodPersistBackend site)
---               )
---              => AzureConf
---              -> User
---              -> ReaderT (YesodPersistBackend site) m (Maybe [(Text, [ByteString])]) -- (Either AzureUserException [(Text, [ByteString])])
--- azureUser' conf User{userIdent}
---   = runMaybeT . catchIfMaybeT (is _AzureUserNoResult) $ azureUser conf (Creds apAzure (CI.original userIdent) [])
-
-
------------------------------------------------
----- OAuth2 + OIDC development auth plugin ----
------------------------------------------------
-
-apAzureMock :: Text
-apAzureMock = "uniworx_dev"
-
-newtype UserID = UserID Text
-instance FromJSON UserID where
-  parseJSON = withObject "UserID" $ \o ->
-    UserID <$> o .: "id"
-
-azureMockServer :: YesodAuth m => String -> AuthPlugin m
-azureMockServer port =
-  let oa = OAuth2
-            { oauth2ClientId = "42"
-            , oauth2ClientSecret = Just "shhh"
-            , oauth2AuthorizeEndpoint = fromString (mockServerURL <> "/auth")
-              `withQuery` [ scopeParam " " ["openid", "profile", "email", "offline_access"] -- TODO read scopes from config
-                          , ("response_type", "code id_token")
-                          , ("nonce", "Foo") -- TODO generate meaningful value
-                          ]
-            , oauth2TokenEndpoint = fromString $ mockServerURL <> "/token"
-            , oauth2RedirectUri = Nothing -- TODO use approot as redirect uri?
-            }
-      mockServerURL = "http://localhost:" <> fromString port
-      profileSrc = fromString $ mockServerURL <> "/users/me"
-  in  authOAuth2 apAzureMock oa $ \manager token -> do
-        (UserID userID, userResponse) <- authGetProfile apAzureMock manager token profileSrc
-        return Creds
-                { credsPlugin = apAzureMock
-                , credsIdent = userID
-                , credsExtra = setExtra token userResponse
-                }
-
-
-----------------------
----- User Queries ----
-----------------------
-
-data UserDataException = UserDataJSONException JSONException
-                       | UserDataInternalException Text
-                       deriving Show
-
-instance Exception UserDataException
-
-queryOAuth2User :: forall j m.
-                   ( FromJSON j
-                   , MonadHandler m
-                   , HasAppSettings (HandlerSite m)
-                   , MonadThrow m
-                   )
-                => Text -- ^ User identifier (arbitrary needle)
-                -> m (Either UserDataException j)
-queryOAuth2User userID = runExceptT $ do
-  (queryUrl, tokenUrl) <- mkBaseUrls
-  req <- parseRequest $ "GET " ++ queryUrl ++ unpack userID
-  mTokens <- lookupSessionJson SessionOAuth2Token
-  unless (isJust mTokens) . throwE $ UserDataInternalException "Tried to load session Oauth2 tokens, but there are none"
-# ifdef DEVELOPMENT
-  let secure = False
-# else
-  let secure = True
-# endif
-  newTokens <- refreshOAuth2Token @m (fromJust mTokens) tokenUrl secure
-  setSessionJson SessionOAuth2Token (Just $ accessToken newTokens, refreshToken newTokens)
-  eResult <- lift $ getResponseBody <$> httpJSONEither @m @j (req
-    { secure = secure
-    , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)]
-    })
-  case eResult of
-    Left x -> throwE $ UserDataJSONException x
-    Right x -> return x
-
-
-mkBaseUrls :: (MonadHandler m, HasAppSettings (HandlerSite m)) => m (String, String)
-mkBaseUrls = do
-# ifndef DEVELOPMENT
-  tenantID <- fmap (maybe (throwM $ UserDataInternalException "Could not determine tenant ID from current app configuration") show) . getsYesod . preview $ _appUserAuthConf . _userAuthConfSingleSource . _AuthSourceConfAzureAdV2 . _azureConfTenantId
-  return ( "https://graph.microsoft.com/v1.0/users/"
-         , "https://login.microsoftonline.com/" ++ tenantID ++ "/oauth2/v2.0" )
-# else
-  port :: String <- liftIO $ maybe (throwM $ UserDataInternalException "Development environment variable OAUTH2_SERVER_PORT is unset") id <$> lookupEnv "OAUTH2_SERVER_PORT"
-  let base = "http://localhost:" ++ port
-  return ( base ++ "/users/query?id="
-         , base ++ "/token" )
-# endif
-
-
-refreshOAuth2Token :: forall m.
-                      ( MonadHandler m
-                      , HasAppSettings (HandlerSite m)
-                      , MonadThrow m
-                      )
-                   => (Maybe AccessToken, Maybe RefreshToken)
-                   -> String
-                   -> Bool
-                   -> ExceptT UserDataException m OAuth2Token
-refreshOAuth2Token (_, Nothing) _ _ = throwE $ UserDataInternalException "Could not refresh access token. Refresh token is missing."
-refreshOAuth2Token (_, Just rToken) url secure = getsYesod (view $ _appUserAuthConf . _userAuthConfSingleSource) >>= \case
-  AuthSourceConfAzureAdV2 AzureConf{..} -> do
-    req <- parseRequest $ "POST " ++ url
-    let
-      body =
-        [ ("grant_type", "refresh_token")
-        , ("refresh_token", encodeUtf8 $ rtoken rToken)
-        ]
-      body'
-        | secure = body ++ [("client_id", fromString $ show azureConfClientId), ("client_secret", fromString $ unpack azureConfClientSecret), scopeParam " " $ Set.toList azureConfScopes]
-        | otherwise = scopeParam " " (Set.toList azureConfScopes) : body
-    $logInfoS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure })
-    eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure })
-    case eResult of
-      Left x -> throwE $ UserDataJSONException x
-      Right x -> return x
-  _other -> throwE $ UserDataInternalException "Could not refresh access token. Invalid/Conflicting auth source configuration."
-
-instance Show RequestBody where
-  show (RequestBodyLBS x) = show x
-  show _ = error ":("
-
-
- -----------------------
----- Single Sign-Out ----
- -----------------------
- 
-singleSignOut :: forall a m. (MonadHandler m)
-              => Maybe Text -- ^ redirect uri
-              -> m a
-singleSignOut mRedirect = do
-# ifdef DEVELOPMENT
-  port <- liftIO $ fromJust <$> lookupEnv "OAUTH2_SERVER_PORT"
-  let base = "http://localhost:" <> pack port <> "/logout"
-# else
-  let base = "" -- TODO find out fraport oidc end_session_endpoint
-# endif
-      endpoint = case mRedirect of
-        Just r -> base <> "?post_logout_redirect_uri=" <> r
-        Nothing -> base
-  $logDebugS "\n\27[31mSSO\27[0m" endpoint 
-  redirect endpoint
-

src/Auth/PWHash.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -68,13 +68,12 @@ hashLogin pwHashAlgo = AuthPlugin{..}
       tp <- getRouteToParent
 
       resp <- formResultMaybe loginRes $ \HashLogin{..} -> Just <$> do
-        user :: Maybe (Entity User) <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
+        user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
         case user of
-          Just (Entity _ User{userIdent,userPasswordHash})
+          Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent })
-            | Just pwHash <- userPasswordHash
+            | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> do -- (2^) is magic.
-            , verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 pwHash) -> do -- (2^) is magic.
                 observeLoginOutcome apName LoginSuccessful
-                setCredsRedirect $ Creds apName (CI.original userIdent) []
+                setCredsRedirect $ Creds apName userIdent []
           other -> do
             $logDebugS apName $ tshow other
             observeLoginOutcome apName LoginInvalidCredentials

src/CryptoID.hs

@@ -59,6 +59,7 @@ decCryptoIDs [ ''SubmissionId
              , ''MaterialFileId
              , ''PrintJobId
              , ''QualificationId
+             , ''SentMailId
              ]
 
 decCryptoIDKeySize

src/Database/Esqueleto/Utils.hs

@@ -15,6 +15,7 @@ module Database.Esqueleto.Utils
   , (=?.), (?=.)
   , (=~.), (~=.)
   , (>~.), (<~.)
+  , (~.), (~*.), (!~.), (!~*.)
   , or, and
   , any, all
   , not__, parens
@@ -26,12 +27,14 @@ module Database.Esqueleto.Utils
   , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
   , mkDayFilter, mkDayFilterFrom, mkDayFilterTo
   , mkExistsFilter, mkExistsFilterWithComma
+  --  , mkRegExFilterWith
   , anyFilter, allFilter
   , ascNullsFirst, descNullsLast
   , orderByList
   , orderByOrd, orderByEnum
   , strip, lower, ciEq
   , selectExists, selectNotExists
+  , filterExists
   , SqlHashable
   , sha256
   , isTrue, isFalse
@@ -41,16 +44,19 @@ module Database.Esqueleto.Utils
   , greatest, least
   , abs
   , SqlProject(..)
-  , (->.), (->>.), (#>>.)
+  , (->.), (->>.), (->>>.), (#>>.)
   , fromSqlKey
   , unKey
   , subSelectCountDistinct
   , selectCountRows, selectCountDistinct
   , selectMaybe
-  , num2text
+  , str2text, str2text'
+  , num2text --, text2num
   , day, day', dayMaybe, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
+  , psqlVersion_
+  , truncateTable
   , module Database.Esqueleto.Utils.TH
   ) where
 
@@ -61,12 +67,16 @@ import qualified Data.Set as Set
 import qualified Data.List as List
 import qualified Data.Foldable as F
 import Data.List.NonEmpty (NonEmpty(..))
+import qualified Database.Persist as P
+import qualified Database.Persist.EntityDef.Internal as P (entityDB)
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Experimental as Ex
 import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Internal.Internal as E
 import Database.Esqueleto.Utils.TH
 
+-- import qualified Database.Persist.Postgresql as P
+
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as Lazy (Text)
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
@@ -156,6 +166,24 @@ infixl 4 <~.
 (<~.) ::  PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
 (<~.) a b = E.isNothing b E.||. (E.just a E.<. b)
 
+infixr 2 ~., ~*., !~., !~*.
+
+-- | PostgreSQL regular expression match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters
+(~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
+(~.) = E.unsafeSqlBinOp    " ~ "
+
+-- | PostgreSQL regular expression match, case insensitive. Works, but may throw SQL errors
+(~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
+(~*.) = E.unsafeSqlBinOp    " ~* "
+
+-- | PostgreSQL regular expression does not match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters
+(!~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
+(!~.) = E.unsafeSqlBinOp    " !~ "
+
+-- | PostgreSQL regular expression does not match, case insensitive. Works, but may throw SQL errors
+(!~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
+(!~*.) = E.unsafeSqlBinOp    " !~* "
+
 
 -- | Negation of `isNothing` which is missing
 isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
@@ -351,7 +379,7 @@ mkExactFilterMaybeLast' lensexists lenslike row criterias
 -- | generic filter creation for dbTable
 --   Given a lens-like function, make filter searching for needles in String-like elements
 --   (Keep Set here to ensure that there are no duplicates)
-mkContainsFilter :: E.SqlString a
+mkContainsFilter :: (E.SqlString a, Ord a)
                  => (t -> E.SqlExpr (E.Value a))  -- ^ getter from query to searched element
                  -> t                             -- ^ query row
                  -> Set.Set a                     -- ^ needle collection
@@ -359,7 +387,7 @@ mkContainsFilter :: E.SqlString a
 mkContainsFilter = mkContainsFilterWith id
 
 -- | like `mkContainsFilter` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter`
-mkContainsFilterWith :: E.SqlString b
+mkContainsFilterWith :: (E.SqlString b, Ord a)
                      => (a -> b)
                      -> (t -> E.SqlExpr (E.Value b))  -- ^ getter from query to searched element
                      -> t                             -- ^ query row
@@ -367,7 +395,7 @@ mkContainsFilterWith :: E.SqlString b
                      -> E.SqlExpr (E.Value Bool)
 mkContainsFilterWith cast lenslike row criterias
   | Set.null criterias = true
-  | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)
+  | otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias
 
 -- | like `mkContainsFilterWith` but allows conversion to produce multiple needles
 mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a)
@@ -378,7 +406,7 @@ mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a)
                      -> E.SqlExpr (E.Value Bool)
 mkContainsFilterWithSet cast lenslike row criterias
   | Set.null criterias = true
-  | otherwise = any (hasInfix $ lenslike row) (E.val <$> Set.toList (foldMap cast criterias))
+  | otherwise = any (hasInfix (lenslike row) . E.val)  (foldMap cast criterias)
 
 -- | like `mkContainsFilterWithSet` but fixed to comma separated Texts
 mkContainsFilterWithComma :: (E.SqlString b, Ord b)
@@ -389,7 +417,7 @@ mkContainsFilterWithComma :: (E.SqlString b, Ord b)
                      -> E.SqlExpr (E.Value Bool)
 mkContainsFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias)
   | Set.null criterias = true
-  | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)
+  | otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias
 
 -- | like `mkContainsFilterWithComma` but enforced the existence of all Texts prefixed with +
 mkContainsFilterWithCommaPlus :: (E.SqlString b, Ord b)
@@ -405,8 +433,20 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c
   | otherwise             = cond_compulsory E.&&. cond_optional
   where
     (Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias
-    cond_compulsory = all (hasInfix $ lenslike row) (E.val . cast <$> Set.toList compulsories)
+    cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories
-    cond_optional   = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList alternatives)
+    cond_optional   = any (hasInfix (lenslike row) . E.val . cast) alternatives
+
+-- like `mkContainsFilterWith` but allows regular expression criterias
+-- This works, but throws SQL errors for unbalanced parenthesis and similar invalid regex expressions
+-- mkRegExFilterWith :: (E.SqlString b, Ord a)
+--                      => (a -> b)
+--                      -> (t -> E.SqlExpr (E.Value b))  -- ^ getter from query to searched element
+--                      -> t                             -- ^ query row
+--                      -> Set.Set a                     -- ^ needle collection
+--                      -> E.SqlExpr (E.Value Bool)
+-- mkRegExFilterWith cast lenslike row criterias
+--   | Set.null criterias = true
+--   | otherwise = any ((~.) (lenslike row) . E.val . cast) criterias
 
 mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime))  -- ^ getter from query to searched element
             -> t                                   -- ^ query row
@@ -451,7 +491,7 @@ mkExistsFilterWithComma :: PathPiece a
                -> E.SqlExpr (E.Value Bool)
 mkExistsFilterWithComma cast query row (foldMap commaSeparatedText -> criterias)
   | Set.null criterias = true
-  | otherwise = any (E.exists . query row) (cast <$> Set.toList criterias)
+  | otherwise = any (E.exists . query row . cast) criterias
 
 
 -- | Combine several filters, using logical or
@@ -510,6 +550,13 @@ selectExists query = do
     _other      -> error "SELECT EXISTS ... returned zero or more than one rows"
 selectNotExists = fmap not . selectExists
 
+filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono))
+             => EntityField val (Element mono) -> mono -> E.SqlReadT m [Element mono]
+filterExists prj vs = fmap (fmap Ex.unValue) <$> Ex.select $ do
+  ent <- Ex.from Ex.table
+  Ex.where_ $ ent Ex.^. prj `Ex.in_` vals vs
+  return   $ ent Ex.^. prj
+
 
 class SqlHashable a
 instance SqlHashable Text
@@ -603,7 +650,7 @@ max, min :: PersistField a
 max a b = bool a b $ b E.>. a
 min a b = bool a b $ b E.<. a
 
--- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least
+-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least; for Bool: t > f
 greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
 greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b)
 
@@ -642,9 +689,16 @@ infixl 8 ->.
 
 infixl 8 ->>.
 
+-- Unsafe variant, see Database.Esqueleto.PostgreSQL.JSON for a safe version!
 (->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text)
 (->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t
 
+infixl 8 ->>>.
+
+-- Unsafe variant to obtain a DB key from a JSON field. Use with caution!
+(->>>.) :: (PersistField (Key entity)) => E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe (Key entity)))
+(->>>.) expr t = E.unsafeSqlCastAs "int" $ E.unsafeSqlBinOp "->>" expr $ E.val t
+
 infixl 8 #>>.
 
 (#>>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value (Maybe Text))
@@ -688,10 +742,21 @@ selectCountDistinct q = do
 selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
 selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
 
+-- | convert something that is like a text to text
+str2text :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Text)
+str2text = E.unsafeSqlCastAs "text"
+
+str2text' :: E.SqlString a => E.SqlExpr (E.Value (Maybe a)) -> E.SqlExpr (E.Value (Maybe Text))
+str2text' = E.unsafeSqlCastAs "text"
+
 -- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers
 num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text)
 num2text = E.unsafeSqlCastAs "text"
 
+-- unsafe, use with care!
+-- text2num :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value n)
+-- text2num = E.unsafeSqlCastAs "int"
+
 day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
 day = E.unsafeSqlCastAs "date"
 
@@ -750,3 +815,16 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2
     ]
     (E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
 
+psqlVersion_ :: E.SqlExpr (E.Value Text)
+psqlVersion_ = E.unsafeSqlFunction "VERSION" ()
+
+-- Suspected to cause trouble. Needs more testing!
+-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record)
+--               => record -> ReaderT backend m ()
+-- truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> "  RESTART IDENTITY") []
+
+truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) -- TODO: test this code
+                  => proxy record -> ReaderT backend m ()
+truncateTable tbl =
+  let tblName :: Text = P.unEntityNameDB $ P.entityDB $ P.entityDef tbl
+  in  E.rawExecute ("TRUNCATE TABLE " <> tblName <> " RESTART IDENTITY") []

src/Foundation/Authorization.hs

@@ -1,4 +1,4 @@
--- 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-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -1521,7 +1521,7 @@ tagAccessPredicate AuthSelf = APDB $ \_ _ mAuthId route _ -> exceptT return retu
       | uid == referencedUser -> return Authorized
     Nothing -> return AuthenticationRequired
     _other  -> unauthorizedI MsgUnauthorizedSelf
-tagAccessPredicate AuthIsExternal = APDB $ \_ _ _ route _ -> exceptT return return $ do
+tagAccessPredicate AuthIsLDAP = APDB $ \_ _ _ route _ -> exceptT return return $ do
   referencedUser <- case route of
     AdminUserR cID -> return cID
     AdminUserDeleteR cID -> return cID
@@ -1529,29 +1529,25 @@ tagAccessPredicate AuthIsExternal = APDB $ \_ _ _ route _ -> exceptT return retu
     UserNotificationR cID -> return cID
     UserPasswordR cID -> return cID
     CourseR _ _ _ (CUserR cID) -> return cID
-    _other -> throwError =<< $unsupportedAuthPredicate AuthIsExternal route
+    _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route
   referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
-  availableSources <- getsYesod (view _appUserAuthConf) >>= \case
+  maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do
-    UserAuthConfSingleSource{..} -> return . singleton $ case userAuthConfSingleSource of
-      AuthSourceConfAzureAdV2 AzureConf{..} -> AuthSourceIdAzure azureConfTenantId
-      AuthSourceConfLdap      LdapConf{..}  -> AuthSourceIdLdap  ldapConfSourceId
-  maybeTMExceptT (unauthorizedI MsgUnauthorizedExternal) $ do
-    Entity _ User{userIdent} <- MaybeT $ getEntity referencedUser'
-    guardM . lift $ exists [ ExternalUserUser ==. userIdent, ExternalUserSource <-. availableSources ]
-  return Authorized
-tagAccessPredicate AuthIsInternal = APDB $ \_ _ _ route _ -> exceptT return return $ do
-  referencedUser <- case route of
-    AdminUserR cID -> return cID
-    AdminUserDeleteR cID -> return cID
-    AdminHijackUserR cID -> return cID
-    UserNotificationR cID -> return cID
-    UserPasswordR cID -> return cID
-    CourseR _ _ _ (CUserR cID) -> return cID
-    _other -> throwError =<< $unsupportedAuthPredicate AuthIsInternal route
-  referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
-  maybeTMExceptT (unauthorizedI MsgUnauthorizedInternal) $ do
     User{..} <- MaybeT $ get referencedUser'
-    guard $ is _Just userPasswordHash
+    guard $ userAuthentication == AuthLDAP
+  return Authorized
+tagAccessPredicate AuthIsPWHash = APDB $ \_ _ _ route _ -> exceptT return return $ do
+  referencedUser <- case route of
+    AdminUserR cID -> return cID
+    AdminUserDeleteR cID -> return cID
+    AdminHijackUserR cID -> return cID
+    UserNotificationR cID -> return cID
+    UserPasswordR cID -> return cID
+    CourseR _ _ _ (CUserR cID) -> return cID
+    _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route
+  referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
+  maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do
+    User{..} <- MaybeT $ get referencedUser'
+    guard $ is _AuthPWHash userAuthentication
   return Authorized
 tagAccessPredicate AuthAuthentication = APDB $ \_ _ mAuthId route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do

src/Foundation/I18n.hs

@@ -8,7 +8,7 @@
 --   3. add constructor to list of module exports
 
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-top-binds #-}
 
 module Foundation.I18n
   ( appLanguages, appLanguagesOpts
@@ -87,21 +87,30 @@ pluralDE num singularForm pluralForm
   | num == 1  = singularForm
   | otherwise = pluralForm
 
--- pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text
+pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text
--- -- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ 
+pluralDEx c n t = pluralDE n t $ t `snoc` c
--- pluralDEx c n t = pluralDE n t $ t `snoc` c
 
--- -- | like `pluralDEe` but also prefixes with the number
+-- | like `pluralDEx` but also prefixes with the number
--- pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text
+pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text
--- pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t)
+pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t)
 
 pluralDEe :: (Eq a, Num a) => a -> Text -> Text
--- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ 
+-- ^ @pluralDEe n "Monat" = pluralDEe n "Monat" "Monate"@
-pluralDEe n t = pluralDE n t $ t `snoc` 'e'
+pluralDEe = pluralDEx 'e'
 
 -- | like `pluralDEe` but also prefixes with the number
 pluralDEeN :: (Eq a, Num a, Show a) => a -> Text -> Text
-pluralDEeN n t = tshow n <> cons ' ' (pluralDEe n t)
+pluralDEeN = pluralDExN 'e'
+
+-- | postfix plural with an 'n'
+pluralDEn :: (Eq a, Num a) => a -> Text -> Text
+-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@
+pluralDEn = pluralDEx 'n'
+
+-- | like `pluralDEn` but also prefixes with the number
+pluralDEnN :: (Eq a, Num a, Show a) => a -> Text -> Text
+pluralDEnN = pluralDExN 'n'
+
 
 noneOneMoreDE :: (Eq a, Num a)
               =>    a -- ^ Count
@@ -114,14 +123,14 @@ noneOneMoreDE num noneText singularForm pluralForm
   | num == 1  = singularForm
   | otherwise = pluralForm
 
--- noneMoreDE :: (Eq a, Num a)
+noneMoreDE :: (Eq a, Num a)
---             =>    a -- ^ Count
+            =>    a -- ^ Count
---             -> Text -- ^ None
+            -> Text -- ^ None
---             -> Text -- ^ Some
+            -> Text -- ^ Some
---             -> Text
+            -> Text
--- noneMoreDE num noneText someText
+noneMoreDE num noneText someText
---   | num == 0  = noneText
+  | num == 0  = noneText
---   | otherwise = someText
+  | otherwise = someText
 
 pluralEN :: (Eq a, Num a)
          =>    a -- ^ Count
@@ -154,14 +163,14 @@ noneOneMoreEN num noneText singularForm pluralForm
   | num == 1  = singularForm
   | otherwise = pluralForm
 
--- noneMoreEN :: (Eq a, Num a)
+noneMoreEN :: (Eq a, Num a)
---             =>    a -- ^ Count
+            =>    a -- ^ Count
---             -> Text -- ^ None
+            -> Text -- ^ None
---             -> Text -- ^ Some
+            -> Text -- ^ Some
---             -> Text
+            -> Text
--- noneMoreEN num noneText someText
+noneMoreEN num noneText someText
---   | num == 0  = noneText
+  | num == 0  = noneText
---   | otherwise = someText
+  | otherwise = someText
 
 _ordinalEN :: ToMessage a
           => a
@@ -210,6 +219,9 @@ maybeBoolMessage Nothing      n _ _ = n
 maybeBoolMessage (Just True)  _ t _ = t
 maybeBoolMessage (Just False) _ _ f = f
 
+-- | Convenience function avoiding type signatures
+boolText :: Text -> Text -> Bool -> Text
+boolText = bool
 
 newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
   deriving stock (Eq, Ord, Read, Show)
@@ -384,6 +396,8 @@ embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id
 embedRenderMessage ''UniWorX ''ChangelogItemKind id
 embedRenderMessage ''UniWorX ''RoomReference' $ dropSuffix "'"
 
+embedRenderMessage ''UniWorX ''AuthenticationMode id
+
 embedRenderMessage ''UniWorX ''RatingValidityException id
 
 embedRenderMessage ''UniWorX ''UrlFieldMessage id
@@ -600,7 +614,7 @@ unRenderMessage = unRenderMessage' (==)
 
 unRenderMessageLenient :: forall a master. (Ord a, Finite a, RenderMessage master a) => master -> Text -> [a]
 unRenderMessageLenient = unRenderMessage' cmp
-  where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode)
+  where cmp = (==) `on` mk . under packed (concatMap $ filter Char.isAlphaNum . unidecode)
 
 
 instance Default DateTimeFormatter where

src/Foundation/Instances.hs

@@ -1,4 +1,4 @@
--- 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>, David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -11,14 +11,11 @@ module Foundation.Instances
   , unsafeHandler
   ) where
 
-import qualified Prelude as P
-
 import Import.NoFoundation
 
 import qualified Data.Text as Text
 import Data.List (inits)
 
-import Yesod.Auth.OAuth2
 import qualified Yesod.Core.Unsafe as Unsafe
 import qualified Yesod.Auth.Message as Auth
 
@@ -26,7 +23,6 @@ import Utils.Form
 import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
-import Auth.OAuth2
 
 import qualified Foundation.Yesod.Session as UniWorX
 import qualified Foundation.Yesod.Middleware as UniWorX
@@ -46,8 +42,6 @@ import Foundation.DB
 
 import Network.Wai.Parse (lbsBackEnd)
 
-import System.Environment (lookupEnv)
-
 import UnliftIO.Pool (withResource)
 
 import qualified Control.Monad.State.Class as State
@@ -134,35 +128,21 @@ instance YesodAuth UniWorX where
     -- Where to send a user after logout
     logoutDest _ = NewsR
     -- Override the above two destinations when a Referer: header is present
-    redirectToReferer _ = False
+    redirectToReferer _ = True
 
     loginHandler = do
-      plugins <- getsYesod authPlugins
-      AppSettings{..} <- getsYesod appSettings'
-
-      when appSingleSignOn $
-        let azurePlugins = P.filter ((`elem` [apAzureMock, apAzure]) . apName) plugins
-         in if
-              | (plugin:_) <- azurePlugins
-              , PluginR _ pieces <- oauth2Url (apName plugin) -> do
-                $logInfoS "SSO" "Azure plugin with plugin url as expected. Calling apDispatch..."
-                void $ apDispatch plugin "GET" pieces
-              | not (null azurePlugins) -> do
-                $logErrorS "SSO" "Azure plugin initialized, but unexpected oauth2Url. Cannot apDispatch."
-              | otherwise -> do
-                $logErrorS "SSO" "No Azure plugin initialized despite SSO being enabled!"
-
       toParent <- getRouteToParent
       liftHandler . defaultLayout $ do
+        plugins <- getsYesod authPlugins
         $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
-        mPort <- liftIO $ lookupEnv "OAUTH2_SERVER_PORT"
+
         setTitleI MsgLoginTitle
         $(widgetFile "login")
 
     authenticate = UniWorX.authenticate
 
-    authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool, appAuthPlugins } = appAuthPlugins ++ catMaybes
+    authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes
-      [ uncurry ldapLogin <$> appLdapPool
+      [ flip campusLogin campusUserFailoverMode <$> appLdapPool
       , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
       , dummyLogin <$ guard appAuthDummyLogin
       ]
@@ -177,11 +157,6 @@ instance YesodAuth UniWorX where
       
       addMessage Success . toHtml $ mr Auth.NowLoggedIn
 
-    -- onLogout = do
-    --   AppSettings{..} <- getsYesod appSettings'
-    --   when appSingleSignOn $ singleSignOut @UniWorX Nothing
-        
-
     onErrorHtml dest msg = do
       addMessage Error $ toHtml msg
       redirect dest

src/Foundation/Navigation.hs

@@ -73,8 +73,6 @@ breadcrumb :: ( BearerAuthSite UniWorX
            => Route UniWorX
            -> m Breadcrumb
 breadcrumb (AuthR _)        = i18nCrumb MsgMenuLogin         $ Just NewsR
-breadcrumb SOutR            = i18nCrumb MsgLogout              Nothing
-breadcrumb SSOutR           = i18nCrumb MsgSingleSignOut       Nothing
 breadcrumb (StaticR _)      = i18nCrumb MsgBreadcrumbStatic    Nothing
 breadcrumb (WellKnownR _)   = i18nCrumb MsgBreadcrumbWellKnown Nothing
 breadcrumb MetricsR         = i18nCrumb MsgBreadcrumbMetrics   Nothing
@@ -89,9 +87,9 @@ breadcrumb (AdminUserR cID) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser $ J
   uid <- decrypt cID
   User{..} <- MaybeT $ get uid
   return (userDisplayName, Just UsersR)
-breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID
+breadcrumb (AdminUserDeleteR    cID) = i18nCrumb MsgBreadcrumbUserDelete  . Just $ AdminUserR cID
-breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID
+breadcrumb (AdminHijackUserR    cID) = i18nCrumb MsgBreadcrumbUserHijack  . Just $ AdminUserR cID
-breadcrumb (UserNotificationR cID) = useRunDB $ do
+breadcrumb (UserNotificationR   cID) = useRunDB $ do
   mayList <- hasReadAccessTo UsersR
   if
     | mayList
@@ -117,13 +115,14 @@ breadcrumb AdminCrontabR        = i18nCrumb MsgBreadcrumbAdminCrontab     $ Just
 breadcrumb AdminJobsR           = i18nCrumb MsgBreadcrumbAdminJobs        $ Just AdminCrontabR
 breadcrumb AdminAvsR            = i18nCrumb MsgMenuAvs                    $ Just AdminR
 breadcrumb AdminAvsUserR{}      = i18nCrumb MsgAvsPersonInfo              $ Just AdminAvsR
-breadcrumb AdminExternalUserR   = i18nCrumb MsgMenuExternalUser           $ Just AdminR
+breadcrumb AdminLdapR           = i18nCrumb MsgMenuLdap                   $ Just AdminR
 breadcrumb AdminProblemsR       = i18nCrumb MsgProblemsHeading            $ Just AdminR
 breadcrumb ProblemUnreachableR  = i18nCrumb MsgProblemsUnreachableHeading $ Just AdminProblemsR
 breadcrumb ProblemWithoutAvsId  = i18nCrumb MsgProblemsNoAvsIdHeading     $ Just AdminProblemsR
 breadcrumb ProblemFbutNoR       = i18nCrumb MsgProblemsRWithoutFHeading   $ Just AdminProblemsR
 breadcrumb ProblemAvsSynchR     = i18nCrumb MsgProblemsAvsSynchHeading    $ Just AdminProblemsR
 breadcrumb ProblemAvsErrorR     = i18nCrumb MsgProblemsAvsErrorHeading    $ Just AdminProblemsR
+breadcrumb ConfigInterfacesR    = i18nCrumb MsgConfigInterfacesHeading    $ Just AdminProblemsR
 
 breadcrumb FirmAllR         = i18nCrumb MsgMenuFirms              Nothing
 breadcrumb FirmsCommR{}     = i18nCrumb MsgMenuFirmsComm        $ Just   FirmAllR
@@ -131,7 +130,13 @@ breadcrumb FirmUsersR{}     = i18nCrumb MsgMenuFirmUsers        $ Just   FirmAll
 breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors  $ Just $ FirmUsersR fsh
 breadcrumb (FirmCommR   fsh)= i18nCrumb MsgMenuFirmsComm        $ Just $ FirmUsersR fsh
 
-breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc              Nothing
+breadcrumb CommCenterR      = i18nCrumb MsgMenuCommCenter       Nothing
+breadcrumb MailCenterR      = i18nCrumb MsgMenuMailCenter     $ Just CommCenterR
+breadcrumb MailHtmlR{}      = i18nCrumb MsgMenuMailHtml       $ Just MailCenterR
+breadcrumb MailPlainR{}     = i18nCrumb MsgMenuMailPlain      $ Just MailCenterR
+breadcrumb (MailAttachmentR mid _) = i18nCrumb MsgMenuMailAttachment $ Just $ MailHtmlR mid
+
+breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc            $ Just CommCenterR
 breadcrumb PrintSendR       = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR
 breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload  $ Just PrintCenterR
 breadcrumb PrintAckR{}      = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR -- never displayed
@@ -544,37 +549,42 @@ defaultLinks :: ( MonadHandler m
                 , BearerAuthSite UniWorX
                 ) => m [Nav]
 defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
-  [ return NavHeaderContainer
+  [ return NavHeader
       { navHeaderRole = NavHeaderSecondary
-      , navLabel      = SomeMessage MsgMenuAccount
+      , navIcon       = IconMenuLogout
-      , navIcon       = IconMenuAccount
+      , navLink       = NavLink
-      , navChildren   =
+        { navLabel       = MsgMenuLogout
-          [ NavLink
+        , navRoute       = AuthR LogoutR
-              { navLabel       = MsgMenuLogout
+        , navAccess'     = NavAccessHandler $ is _Just <$> maybeAuthId
-              , navRoute       = SSOutR -- AuthR LogoutR
+        , navType        = NavTypeLink { navModal = False }
-              , navAccess'     = NavAccessHandler $ is _Just <$> maybeAuthId
+        , navQuick'      = mempty
-              , navType        = NavTypeLink { navModal = False }
+        , navForceActive = False
-              , navQuick'      = mempty
+        }
-              , navForceActive = False
+      }
-              }
+  , return NavHeader
-          , NavLink
+      { navHeaderRole = NavHeaderSecondary
-              { navLabel       = MsgMenuLogin
+      , navIcon       = IconMenuLogin
-              , navRoute       = AuthR LoginR
+      , navLink       = NavLink
-              , navAccess'     = NavAccessHandler $ is _Nothing <$> maybeAuthId
+        { navLabel       = MsgMenuLogin
-              , navType        = NavTypeLink { navModal = False }
+        , navRoute       = AuthR LoginR
-              , navQuick'      = mempty
+        , navAccess'     = NavAccessHandler $ is _Nothing <$> maybeAuthId
-              , navForceActive = False
+        , navType        = NavTypeLink { navModal = True }
-              }
+        , navQuick'      = mempty
-          , NavLink
+        , navForceActive = False
-              { navLabel       = MsgMenuProfile
+        }
-              , navRoute       = ProfileR
+      }
-              , navAccess'     = NavAccessHandler $ is _Just <$> maybeAuthId
+  , return NavHeader
-              , navType        = NavTypeLink { navModal = False }
+      { navHeaderRole = NavHeaderSecondary
-              , navQuick'      = mempty
+      , navIcon       = IconMenuProfile
-              , navForceActive = False
+      , navLink       = NavLink
-              }
+        { navLabel       = MsgMenuProfile
-          ]
+        , navRoute       = ProfileR
-  }
+        , navAccess'     = NavAccessHandler $ is _Just <$> maybeAuthId
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
   , do
       mCurrentRoute <- getCurrentRoute
 
@@ -853,8 +863,8 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
               , navForceActive = False
               }
           , NavLink
-              { navLabel       = MsgMenuExternalUser
+              { navLabel       = MsgMenuLdap
-              , navRoute       = AdminExternalUserR
+              , navRoute       = AdminLdapR
               , navAccess'     = NavAccessTrue
               , navType        = NavTypeLink { navModal = False }
               , navQuick'      = mempty
@@ -1211,8 +1221,8 @@ pageActions (AdminUserR cID) = return
       , navRoute       = UserPasswordR cID
       , navAccess' = NavAccessDB $ do
           uid <- decrypt cID
-          User{userPasswordHash} <- get404 uid
+          User{userAuthentication} <- get404 uid
-          return $ is _Just userPasswordHash
+          return $ is _AuthPWHash userAuthentication
       , navType        = NavTypeLink { navModal = True }
       , navQuick'      = mempty
       , navForceActive = False
@@ -1454,6 +1464,12 @@ pageActions (ForProfileR cID) = return
     , navChildren = []
     }
   ]
+pageActions (ForProfileDataR cID) = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgAdminUserHeading $ AdminUserR cID
+    , navChildren = []
+    }
+  ]
 pageActions TermShowR = do
   participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
   return
@@ -2468,6 +2484,50 @@ pageActions PrintCenterR = do
   dayLinks <- mapM toDayAck $ Map.toAscList dayMap
   return $ manualSend : printLog : printAck : take 9 dayLinks
 
+pageActions CommCenterR = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgMenuMailCenter MailCenterR
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = defNavLink MsgMenuApc PrintCenterR
+    , navChildren = []
+    }
+  ]
+
+pageActions (MailHtmlR smid) = do
+  sid <- decrypt smid
+  usrNotiSettings <- useRunDB $ runMaybeT $ do
+    sm <- MaybeT $ get sid
+    uid <- hoistMaybe $ sentMailRecipient sm
+    User{userDisplayName} <- MaybeT $ get uid
+    uuid <- liftHandler $ encrypt uid
+    return NavPageActionPrimary
+        { navLink = defNavLink (MsgNotificationSettingsHeading userDisplayName) $ UserNotificationR uuid
+        , navChildren = []
+        }
+  let linkPlain = NavPageActionPrimary
+        { navLink = defNavLink MsgMenuMailPlain $ MailPlainR smid
+        , navChildren = []
+        }
+  return $ msnoc [linkPlain] usrNotiSettings
+pageActions (MailPlainR smid) = do
+  sid <- decrypt smid
+  usrNotiSettings <- useRunDB $ runMaybeT $ do
+    sm <- MaybeT $ get sid
+    uid <- hoistMaybe $ sentMailRecipient sm
+    User{userDisplayName} <- MaybeT $ get uid
+    uuid <- liftHandler $ encrypt uid
+    return NavPageActionPrimary
+        { navLink = defNavLink (MsgNotificationSettingsHeading userDisplayName) $ UserNotificationR uuid
+        , navChildren = []
+        }
+  let linkHtml = NavPageActionPrimary
+        { navLink = defNavLink MsgMenuMailHtml $ MailHtmlR smid
+        , navChildren = []
+        }
+  return $ msnoc [linkHtml] usrNotiSettings
+
 pageActions AdminCrontabR = return
   [ NavPageActionPrimary
     { navLink = defNavLink MsgMenuAdminJobs AdminJobsR
@@ -2475,6 +2535,20 @@ pageActions AdminCrontabR = return
     }
   ]
 
+pageActions AdminProblemsR = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgConfigInterfacesHeading ConfigInterfacesR
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = defNavLink MsgProblemsAvsSynchHeading ProblemAvsSynchR
+    , navChildren = []
+    }
+  , NavPageActionSecondary
+    { navLink = defNavLink MsgProblemsAvsErrorHeading ProblemAvsErrorR
+    }
+  ]
+
 pageActions _ = return []
 
 submissionList :: ( MonadIO m

src/Foundation/SiteLayout.hs

@@ -157,10 +157,6 @@ siteLayout' overrideHeading widget = do
 
   isAuth <- isJust <$> maybeAuthId
   
-  when (appAutoSignOn && not isAuth) $ do
-    $logDebugS "AutoSignOn" "AutoSignOn is enabled in AppSettings and user is not authenticated"
-    redirect $ AuthR LoginR
-  
   now <- liftIO getCurrentTime
 
   muid <- maybeAuthPair

src/Foundation/Type.hs

@@ -15,7 +15,7 @@ module Foundation.Type
   , _memcachedLocalARC
   , SMTPPool
   , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache, _appAvsQuery
-  , DB, Form, MsgRenderer, MailM, DBFile
+  , DB, DBRead, Form, MsgRenderer, MailM, DBFile
   ) where
 
 import Import.NoFoundation
@@ -43,7 +43,7 @@ import Data.Time.Clock.POSIX (POSIXTime)
 import GHC.Fingerprint (Fingerprint)
 import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey)
 
-import Utils.Avs (AvsQuery)
+import Utils.Avs (AvsQuery())
 
 
 type SMTPPool = Pool SMTPConnection
@@ -79,7 +79,7 @@ data UniWorX = UniWorX
     , appStatic            :: EmbeddedStatic -- ^ Settings for static file serving.
     , appConnPool          :: forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend -- ^ Database connection pool.
     , appSmtpPool          :: Maybe SMTPPool
-    , appLdapPool          :: Maybe (LdapConf, LdapPool) -- TODO: reintroduce Failover
+    , appLdapPool          :: Maybe (Failover (LdapConf, LdapPool))
     , appWidgetMemcached   :: Maybe Memcached.Connection -- ^ Actually a proper pool
     , appHttpManager       :: Manager
     , appLogger            :: (ReleaseKey, TVar Logger)
@@ -97,7 +97,6 @@ data UniWorX = UniWorX
     , appUploadCache       :: Maybe MinioConn
     , appVerpSecret        :: VerpSecret
     , appAuthKey           :: Auth.Key
-    , appAuthPlugins       :: [AuthPlugin UniWorX]
     , appFileSourceARC     :: Maybe (ARCHandle (FileContentChunkReference, (Int, Int)) Int ByteString)
     , appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString)
     , appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference))
@@ -126,6 +125,7 @@ instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where
 
 
 type DB = YesodDB UniWorX
+type DBRead = ReaderT SqlReadBackend (HandlerFor UniWorX)
 type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ())
 type MsgRenderer = MsgRendererS UniWorX -- see Utils
 type MailM a = MailT (HandlerFor UniWorX) a

src/Foundation/Types.hs

@@ -1,44 +1,23 @@
--- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Foundation.Types
-  ( UpsertUserMode(..)
+  ( UpsertCampusUserMode(..)
-  , _UpsertUserLogin, _UpsertUserLoginDummy, _UpsertUserLoginOther, _UpsertUserSync, _UpsertUserGuessUser
+  , _UpsertCampusUserLoginLdap, _UpsertCampusUserLoginDummy, _UpsertCampusUserLoginOther, _UpsertCampusUserLdapSync, _UpsertCampusUserGuessUser
-  , _upsertUserSource, _upsertUserIdent
+  , _upsertCampusUserIdent
-  , UpsertUserData(..)
-  , _UpsertUserDataAzure, _UpsertUserDataLdap
-  , _upsertUserAzureTenantId, _upsertUserAzureData, _upsertUserLdapHost, _upsertUserLdapData
   ) where
 
 import Import.NoFoundation
 
-import qualified Ldap.Client as Ldap
 
+data UpsertCampusUserMode
+  = UpsertCampusUserLoginLdap
+  | UpsertCampusUserLoginDummy { upsertCampusUserIdent :: UserIdent }
+  | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent } -- erlaubt keinen späteren Login
+  | UpsertCampusUserLdapSync   { upsertCampusUserIdent :: UserIdent }
+  | UpsertCampusUserGuessUser
+  deriving (Eq, Ord, Read, Show, Generic)
 
--- TODO: rename?
+makeLenses_ ''UpsertCampusUserMode
-data UpsertUserMode
+makePrisms ''UpsertCampusUserMode
-  = UpsertUserLogin      { upsertUserSource :: Text } -- TODO: use type synonym?
-  | UpsertUserLoginDummy { upsertUserIdent  :: UserIdent }
-  | UpsertUserLoginOther { upsertUserIdent  :: UserIdent } -- does not allow further login
-  | UpsertUserSync       { upsertUserIdent  :: UserIdent }
-  | UpsertUserGuessUser
-  deriving (Show)
-
-makeLenses_ ''UpsertUserMode
-makePrisms ''UpsertUserMode
-
-
-data UpsertUserData
-  = UpsertUserDataAzure
-    { upsertUserAzureTenantId :: UUID
-    , upsertUserAzureData     :: [(Text, [ByteString])]  -- TODO: use type synonym?
-    }
-  | UpsertUserDataLdap
-    { upsertUserLdapHost      :: Text
-    , upsertUserLdapData      :: Ldap.AttrList []
-    }
-  deriving (Show)
-
-makeLenses_ ''UpsertUserData
-makePrisms ''UpsertUserData

src/Foundation/Yesod/Auth.hs

@@ -1,66 +1,69 @@
--- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Foundation.Yesod.Auth
   ( authenticate
-  , userLookupAndUpsert
+  , ldapLookupAndUpsert
-  , upsertUser, maybeUpsertUser
+  , upsertCampusUser
   , decodeUserTest
-  , DecodeUserException(..)
+  , CampusUserConversionException(..)
-  , updateUserLanguage
+  , campusUserFailoverMode, updateUserLanguage
   ) where
 
 import Import.NoFoundation hiding (authenticate)
 
-import Auth.Dummy (apDummy)
-import Auth.LDAP
-import Auth.OAuth2
-import Auth.PWHash (apHash)
-
 import Foundation.Type
 import Foundation.Types
 import Foundation.I18n
 
--- import Handler.Utils.Profile
+import Handler.Utils.Profile
 import Handler.Utils.LdapSystemFunctions
 import Handler.Utils.Memcached
 import Foundation.Authorization (AuthorizationCacheKey(..))
 
 import Yesod.Auth.Message
-import Yesod.Auth.OAuth2 (getAccessToken, getRefreshToken)
+import Auth.LDAP
+import Auth.PWHash (apHash)
+import Auth.Dummy (apDummy)
 
-import qualified Control.Monad.Catch as C (Handler(..))
-
-import qualified Data.ByteString as ByteString
 import qualified Data.CaseInsensitive as CI
-import qualified Data.Map as Map
+import qualified Control.Monad.Catch as C (Handler(..))
-import qualified Data.List.NonEmpty as NonEmpty (toList)
+import qualified Ldap.Client as Ldap
-import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
+import qualified Data.ByteString as ByteString
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+-- import qualified Data.Conduit.Combinators as C
 
-import qualified Ldap.Client as Ldap
+-- import qualified Data.List as List ((\\))
+
+-- import qualified Data.UUID as UUID
+-- import Data.ByteArray (convert)
+-- import Crypto.Hash (SHAKE128)
+-- import qualified Data.Binary as Binary
+
+-- import qualified Database.Esqueleto.Legacy as E
+-- import qualified Database.Esqueleto.Utils as E
+
+-- import Crypto.Hash.Conduit (sinkHash)
 
 
 authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
                 , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
                 , YesodAuth UniWorX, UserId ~ AuthId UniWorX
                 )
-             => Creds UniWorX
+             => Creds UniWorX -> m (AuthenticationResult UniWorX)
-             -> m (AuthenticationResult UniWorX)
 authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
-  $logDebugS "Auth Debug" $ "\a\27[31m" <> tshow creds <> "\27[0m"
-  setSessionJson SessionOAuth2Token (getAccessToken creds, getRefreshToken creds)
-
   now <- liftIO getCurrentTime
 
   let
     uAuth = UniqueAuthentication $ CI.mk credsIdent
-    upsertMode = creds ^? _upsertUserMode
+    upsertMode = creds ^? _upsertCampusUserMode
 
-    isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode
+    isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode
-    isOther = is (_Just . _UpsertUserLoginOther) upsertMode
+    isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode
 
     excRecovery res
       | isDummy || isOther
@@ -74,21 +77,21 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
       = return res
 
     excHandlers =
-      [ C.Handler $ \(fExc :: FetchUserDataException) -> case fExc of
+      [ C.Handler $ \case
-          FetchUserDataNoResult -> do
+          CampusUserNoResult -> do
-            $logWarnS "FetchUserException" $ "User lookup failed after successful login for " <> credsIdent
+            $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
             excRecovery . UserError $ IdentifierNotFound credsIdent
-          FetchUserDataAmbiguous -> do
+          CampusUserAmbiguous -> do
-            $logWarnS "FetchUserException" $ "Multiple User results for " <> credsIdent
+            $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
             excRecovery . UserError $ IdentifierNotFound credsIdent
           err -> do
-            $logErrorS "FetchUserException" $ tshow err
+            $logErrorS "LDAP" $ tshow err
             mr <- getMessageRender
-            excRecovery . ServerError $ mr MsgInternalLoginError
+            excRecovery . ServerError $ mr MsgInternalLdapError
-      , C.Handler $ \(dExc :: DecodeUserException) -> do
+      , C.Handler $ \(cExc :: CampusUserConversionException) -> do
-          $logErrorS "Auth" $ tshow dExc
+          $logErrorS "LDAP" $ tshow cExc
           mr <- getMessageRender
-          excRecovery . ServerError $ mr dExc
+          excRecovery . ServerError $ mr cExc
       ]
 
     acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
@@ -104,300 +107,230 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
           | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
         _other -> return res
 
-  $logDebugS "Auth" $ tshow Creds{..}
+  $logDebugS "auth" $ tshow Creds{..}
+  ldapPool' <- getsYesod $ view _appLdapPool
 
-  flip catches excHandlers $ if
+  flip catches excHandlers $ case ldapPool' of
-    | not isDummy, not isOther
+    Just ldapPool
-    , Just upsertMode' <- upsertMode -> fetchUserData Creds{..} >>= \case
+      | Just upsertMode' <- upsertMode -> do
-      Just userData -> do
+          ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
-        $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData
+          $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
-        Authenticated . entityKey <$> upsertUser upsertMode' userData
+          Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
-      Nothing
+    _other
-        -> throwM FetchUserDataNoResult
-    | otherwise
       -> acceptExisting
 
 
-data DecodeUserException
+data CampusUserConversionException
-  = DecodeUserInvalidIdent
+  = CampusUserInvalidIdent
-  | DecodeUserInvalidEmail
+  | CampusUserInvalidEmail
-  | DecodeUserInvalidDisplayName
+  | CampusUserInvalidDisplayName
-  | DecodeUserInvalidGivenName
+  | CampusUserInvalidGivenName
-  | DecodeUserInvalidSurname
+  | CampusUserInvalidSurname
-  | DecodeUserInvalidTitle
+  | CampusUserInvalidTitle
-  | DecodeUserInvalidFeaturesOfStudy Text
+  -- | CampusUserInvalidMatriculation
-  | DecodeUserInvalidAssociatedSchools Text
+  | CampusUserInvalidFeaturesOfStudy Text
+  | CampusUserInvalidAssociatedSchools Text
   deriving (Eq, Ord, Read, Show, Generic)
   deriving anyclass (Exception)
 
-
+_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
-_upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode
+_upsertCampusUserMode mMode cs@Creds{..}
-_upsertUserMode mMode cs@Creds{..}
+  | credsPlugin == apDummy = setMode <$> mMode (UpsertCampusUserLoginDummy $ CI.mk credsIdent)
-  | credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent)
+  | credsPlugin == apLdap  = setMode <$> mMode  UpsertCampusUserLoginLdap
-  | credsPlugin `elem` loginAPs
+  | otherwise              = setMode <$> mMode (UpsertCampusUserLoginOther $ CI.mk credsIdent)
-                           = setMode <$> mMode (UpsertUserLogin credsPlugin)
-  | otherwise              = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent)
   where
-    setMode UpsertUserLogin{..} | upsertUserSource `elem` loginAPs
+    setMode UpsertCampusUserLoginLdap
-      = cs { credsPlugin = upsertUserSource }
+      = cs{ credsPlugin = apLdap }
-    setMode UpsertUserLoginDummy{..}
+    setMode (UpsertCampusUserLoginDummy ident)
-      = cs { credsPlugin = apDummy
+      = cs{ credsPlugin = apDummy
-           , credsIdent  = CI.original upsertUserIdent
+          , credsIdent  = CI.original ident
-           }
+          }
-    setMode UpsertUserLoginOther{..}
+    setMode (UpsertCampusUserLoginOther ident)
-      = cs { credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure])
+      = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap)
-           , credsIdent  = CI.original upsertUserIdent
+          , credsIdent  = CI.original ident
-           }
+          }
     setMode _ = cs
 
-    loginAPs = [ apAzure, apLdap ]
     defaultOther = apHash
 
+ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)
+ldapLookupAndUpsert ident =
+  getsYesod (view _appLdapPool) >>= \case
+    Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
+    Just ldapPool ->
+      campusUser'' ldapPool campusUserFailoverMode ident >>= \case
+        Nothing -> throwM CampusUserNoResult
+        Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse
 
-userLookupAndUpsert :: forall m.
+{- THIS FUNCION JUST DECODES, BUT IT DOES NOT QUERY LDAP!
-                       ( MonadHandler m
+upsertCampusUserByCn :: forall m.
-                       , HandlerSite m ~ UniWorX
+                        ( MonadHandler m, HandlerSite m ~ UniWorX
-                       , MonadMask m
+                        , MonadThrow m
-                       , MonadUnliftIO m
+                        )
-                       )
+                      => Text -> SqlPersistT m (Entity User)
-                    => Text
+upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])]
-                    -> UpsertUserMode
+-}
-                    -> SqlPersistT m (Maybe (Entity User))
-userLookupAndUpsert credsIdent mode =
-  fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= maybeUpsertUser mode
 
-
+-- | Upsert User DB according to given LDAP data (does not query LDAP itself)
-data FetchUserDataException
+upsertCampusUser :: forall m.
-  = FetchUserDataNoResult
+                    ( MonadHandler m, HandlerSite m ~ UniWorX
-  | FetchUserDataAmbiguous
+                    , MonadCatch m
-  | FetchUserDataException
+                    )
-  deriving (Eq, Ord, Read, Show, Generic)
+                 => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
-  deriving anyclass (Exception)
+upsertCampusUser upsertMode ldapData = do
-
--- | Fetch user data with given credentials from external source(s)
-fetchUserData :: forall m site.
-                 ( MonadHandler m
-                 , HandlerSite m ~ UniWorX
-                 , MonadCatch m
-                 , MonadMask m
-                 , MonadUnliftIO m
-                 )
-              => Creds site
-              -> SqlPersistT m (Maybe (NonEmpty UpsertUserData))
-fetchUserData Creds{..} = do
-  userAuthConf <- getsYesod $ view _appUserAuthConf
-  now <- liftIO getCurrentTime
-
-  results :: Maybe (NonEmpty UpsertUserData) <- case userAuthConf of
-    UserAuthConfSingleSource{..} -> fmap (:| []) <$> case userAuthConfSingleSource of
-      AuthSourceConfAzureAdV2 AzureConf{ azureConfClientId = upsertUserAzureTenantId } -> do
-        queryOAuth2User @[(Text, [ByteString])] credsIdent >>= \case
-          Right upsertUserAzureData -> return $ Just UpsertUserDataAzure{..}
-          Left _ -> return Nothing
-      AuthSourceConfLdap LdapConf{..} -> getsYesod (view _appLdapPool) >>= \case
-        Just ldapPool -> fmap (UpsertUserDataLdap ldapConfSourceId) <$> ldapUser'' ldapPool credsIdent
-        Nothing -> throwM FetchUserDataException
-
-  -- insert ExternalUser entries for each fetched dataset
-  whenIsJust results $ \ress -> forM_ ress $ \res -> do
-    let externalUserLastSync = now
-        (externalUserData, externalUserSource) = case res of
-          UpsertUserDataAzure{..} -> (toJSON upsertUserAzureData, AuthSourceIdAzure upsertUserAzureTenantId)
-          UpsertUserDataLdap{..} -> (toJSON upsertUserLdapData, AuthSourceIdLdap upsertUserLdapHost)
-    externalUserUser <- if
-      | UpsertUserDataAzure{..} <- res
-      , azureData <- Map.fromListWith (++) $ upsertUserAzureData <&> second (filter (not . ByteString.null))
-      , [Text.decodeUtf8' -> Right azureUserPrincipalName'] <- azureData !!! azureUserPrincipalName
-        -> return $ CI.mk azureUserPrincipalName'
-      | UpsertUserDataLdap{..} <- res
-      , ldapData <- Map.fromListWith (++) $ upsertUserLdapData <&> second (filter (not . ByteString.null))
-      , [Text.decodeUtf8' -> Right ldapPrimaryKey'] <- ldapData !!! ldapPrimaryKey
-        -> return $ CI.mk ldapPrimaryKey'
-      | otherwise
-        -> throwM DecodeUserInvalidIdent
-    void $ upsert ExternalUser{..} [ExternalUserData =. externalUserData, ExternalUserLastSync =. externalUserLastSync]
-
-  return results
-
-
--- | Upsert User and related auth in DB according to given external source data (does not query source itself)
-maybeUpsertUser :: forall m.
-                   ( MonadHandler m
-                   , HandlerSite m ~ UniWorX
-                   , MonadCatch m
-                   )
-                => UpsertUserMode
-                -> Maybe (NonEmpty UpsertUserData)
-                -> SqlPersistT m (Maybe (Entity User))
-maybeUpsertUser _upsertMode Nothing = return Nothing
-maybeUpsertUser _upsertMode (Just upsertData) = do
   now <- liftIO getCurrentTime
   userDefaultConf <- getsYesod $ view _appUserDefaults
 
-  (newUser,userUpdate) <- decodeUser now userDefaultConf upsertData
+  (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
-  --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
 
-  oldUsers <- selectKeysList [ UserIdent ==. userIdent newUser ] []
+  oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
 
-  user@(Entity userId _userRec) <- case oldUsers of
+  user@(Entity userId userRec) <- case oldUsers of
-    [oldUserId] -> updateGetEntity oldUserId userUpdate
+    Just [oldUserId] -> updateGetEntity oldUserId userUpdate
-    _other      -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
+    _other           -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
+  unless (validDisplayName (newUser ^. _userTitle)
+                           (newUser ^. _userFirstName)
+                           (newUser ^. _userSurname)
+                           (userRec ^. _userDisplayName)) $
+    update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]  -- update invalid display names only
+  when (validEmail' (userRec ^. _userEmail)) $ do                         -- RECALL: userRec already contains basic updates
+    let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
+              ++ [ UserAuthentication =. AuthLDAP                 | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
+    update userId emUps -- update already checks whether list is empty
+    -- Attempt to update ident, too:
+    unless (validEmail' (userRec ^. _userIdent)) $
+      void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
 
   let
     userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
-    userSystemFunctions' = concat $ upsertData <&> \case
+    userSystemFunctions' = do
-      UpsertUserDataAzure{..} -> do
+      (k, v) <- ldapData
-        (_k, v) <- upsertUserAzureData
+      guard $ k == ldapAffiliation
-        v' <- v
+      v' <- v
-        Right str <- return $ Text.decodeUtf8' v'
+      Right str <- return $ Text.decodeUtf8' v'
-        assertM' (not . Text.null) $ Text.strip str
+      assertM' (not . Text.null) $ Text.strip str
-      UpsertUserDataLdap{..} -> do
-        (k, v) <- upsertUserLdapData
-        guard $ k == ldapAffiliation
-        v' <- v
-        Right str <- return $ Text.decodeUtf8' v'
-        assertM' (not . Text.null) $ Text.strip str
 
   iforM_ userSystemFunctions $ \func preset -> do
     memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
     if | preset -> void $ upsert (UserSystemFunction userId func False False) []
        | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
 
-  return $ Just user
+  return user
 
-upsertUser :: forall m.
+decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
-              ( MonadHandler m
+        => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User]))
-              , HandlerSite m ~ UniWorX
+decodeUserTest mbIdent ldapData = do
-              , MonadCatch m
+    now <- liftIO getCurrentTime
-              )
+    userDefaultConf <- getsYesod $ view _appUserDefaults
-           => UpsertUserMode
+    let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent
-           -> NonEmpty UpsertUserData
+    try $ decodeUser now userDefaultConf mode ldapData
-           -> SqlPersistT m (Entity User)
-upsertUser upsertMode upsertData = maybeUpsertUser upsertMode (Just upsertData) >>= \case
-  Nothing -> error "upsertUser: No user result from maybeUpsertUser!"
-  Just user -> return user
 
 
-decodeUser :: ( MonadThrow m
+decodeUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
-              )
+decodeUser now UserDefaultConf{..} upsertMode ldapData = do
-           => UTCTime -- ^ Now
+    let
-           -> UserDefaultConf
+      userTelephone             = decodeLdap ldapUserTelephone <&> canonicalPhone
-           -> NonEmpty UpsertUserData -- ^ Raw source data
+      userMobile                = decodeLdap ldapUserMobile    <&> canonicalPhone
-           -> m (User,_) -- ^ Data for new User entry and updating existing User entries
+      userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
-decodeUser now UserDefaultConf{..} upsertData = do
+      userCompanyDepartment     = decodeLdap ldapUserFraportAbteilung
+
+      userAuthentication
+        | is _UpsertCampusUserLoginOther upsertMode
+                    = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
+        | otherwise = AuthLDAP
+      userLastAuthentication = guardOn isLogin now
+      isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
+
+      userTitle       = decodeLdap  ldapUserTitle     -- CampusUserInvalidTitle
+      userFirstName   = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
+      userSurname     = decodeLdap' ldapUserSurname   -- CampusUserInvalidSurname
+    userDisplayName <- decodeLdap1  ldapUserDisplayName  CampusUserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
+
+    --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
+    -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
+
     userIdent <- if
-      | Just azureData <- mbAzureData
+      | [bs] <- ldapMap !!! ldapUserPrincipalName
-      , [Text.decodeUtf8' -> Right azureUserPrincipalName'] <- azureData !!! azureUserPrincipalName
+      , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
-      , Just azureUserPrincipalName'' <- assertM' (not . Text.null) $ Text.strip azureUserPrincipalName'
+      , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
-        -> return $ CI.mk azureUserPrincipalName''
+        -> return userIdent'
-      | Just ldapData <- mbLdapData
+      | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
-      , [Text.decodeUtf8' -> Right ldapPrimaryKey'] <- ldapData !!! ldapPrimaryKey
+        -> return userIdent'
-      , Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
-        -> return $ CI.mk ldapPrimaryKey''
       | otherwise
-        -> throwM DecodeUserInvalidIdent
+        -> throwM CampusUserInvalidIdent
+
+    userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E<number@fraport.de` here, too strong! Make Email-Field optional!
+      | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
+         -> return $ CI.mk userEmail
+      --   | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
+      --      -> return $ CI.mk userEmail
+      | otherwise
+        -> throwM CampusUserInvalidEmail
+
+    userLdapPrimaryKey <- if
+      | [bs] <- ldapMap !!! ldapPrimaryKey
+      , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
+      , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
+        -> return $ Just userLdapPrimaryKey'''
+      | otherwise
+        -> return Nothing
 
     let
-      (azureSurname, azureFirstName, azureDisplayName, azureEmail, azureTelephone, azureMobile, azureLanguages)
-        | Just azureData <- mbAzureData
-          = ( azureData `decodeAzure` azureUserSurname
-            , azureData `decodeAzure` azureUserGivenName
-            , azureData `decodeAzure` azureUserDisplayName
-            , azureData `decodeAzure` azureUserMail
-            , azureData `decodeAzure` azureUserTelephone
-            , azureData `decodeAzure` azureUserMobile
-            , Nothing -- azureData `decodeAzure` azureUserPreferredLanguage -- TODO: parse Languages from azureUserPreferredLanguage
-            )
-        | otherwise
-          = ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing )
-
-      (ldapSurname, ldapFirstName, ldapDisplayName, ldapEmail, ldapTelephone, ldapMobile, ldapCompanyPersonalNumber, ldapCompanyDepartment)
-        | Just ldapData <- mbLdapData
-          = ( ldapData `decodeLdap` ldapUserSurname
-            , ldapData `decodeLdap` ldapUserFirstName
-            , ldapData `decodeLdap` ldapUserDisplayName
-            , ldapData `decodeLdap` Ldap.Attr "mail" -- TODO: use ldapUserEmail?
-            , ldapData `decodeLdap` ldapUserTelephone
-            , ldapData `decodeLdap` ldapUserMobile
-            , ldapData `decodeLdap` ldapUserFraportPersonalnummer
-            , ldapData `decodeLdap` ldapUserFraportAbteilung
-            )
-        | otherwise
-          = ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing )
-
-    -- TODO: throw on collisions?
-
-    -- TODO: use user-auth precedence from app config when implementing multi-source support
-    let
-      userSurname = fromMaybe mempty $ azureSurname <|> ldapSurname
-      userFirstName = fromMaybe mempty $ azureFirstName <|> ldapFirstName
-      userDisplayName = fromMaybe mempty $ azureDisplayName <|> ldapDisplayName
-      userEmail = maybe mempty CI.mk $ azureEmail <|> ldapEmail
-      userTelephone = azureTelephone <|> ldapTelephone
-      userMobile = azureMobile <|> ldapMobile
-      userLanguages = azureLanguages
-      userCompanyPersonalNumber = ldapCompanyPersonalNumber
-      userCompanyDepartment = ldapCompanyDepartment
-
       newUser = User
-        { userMaxFavourites         =  userDefaultMaxFavourites
+        { userMaxFavourites           = userDefaultMaxFavourites
-        , userMaxFavouriteTerms     =  userDefaultMaxFavouriteTerms
+        , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
-        , userTheme                 =  userDefaultTheme
+        , userTheme                   = userDefaultTheme
-        , userDateTimeFormat        =  userDefaultDateTimeFormat
+        , userDateTimeFormat          = userDefaultDateTimeFormat
-        , userDateFormat            =  userDefaultDateFormat
+        , userDateFormat              = userDefaultDateFormat
-        , userTimeFormat            =  userDefaultTimeFormat
+        , userTimeFormat              = userDefaultTimeFormat
-        , userDownloadFiles         =  userDefaultDownloadFiles
+        , userDownloadFiles           = userDefaultDownloadFiles
-        , userWarningDays           =  userDefaultWarningDays
+        , userWarningDays             = userDefaultWarningDays
-        , userShowSex               =  userDefaultShowSex
+        , userShowSex                 = userDefaultShowSex
-        , userSex                   =  Nothing
+        , userSex                     = Nothing
-        , userBirthday              =  Nothing
+        , userBirthday                = Nothing
-        , userTitle                 =  Nothing
+        , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
-        , userExamOfficeGetSynced   =  userDefaultExamOfficeGetSynced
+        , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
-        , userExamOfficeGetLabels   =  userDefaultExamOfficeGetLabels
+        , userNotificationSettings    = def
-        , userNotificationSettings  =  def
+        , userLanguages               = Nothing
-        , userCsvOptions            =  def
+        , userCsvOptions              = def
-        , userTokensIssuedAfter     =  Nothing
+        , userTokensIssuedAfter       = Nothing
-        , userDisplayEmail          =  userEmail
+        , userCreated                 = now
-        , userMatrikelnummer        =  Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
+        , userLastLdapSynchronisation = Just now
-        , userPostAddress           =  Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
+        , userDisplayName             = userDisplayName
-        , userPostLastUpdate        =  Nothing
+        , userDisplayEmail            = userEmail
-        , userPinPassword           =  Nothing -- must be derived via AVS
+        , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-        , userPrefersPostal         =  userDefaultPrefersPostal
+        , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-        , userPasswordHash          =  Nothing
+        , userPostLastUpdate          = Nothing
-        , userLastAuthentication    =  Nothing
+        , userPinPassword             = Nothing -- must be derived via AVS
-        , userCreated               =  now
+        , userPrefersPostal           = userDefaultPrefersPostal
-        , userLastSync              =  Just now
         , ..
         }
       userUpdate =
-        [ UserSurname               =. userSurname
+        [ UserLastAuthentication      =. Just now  | isLogin ] ++
-        , UserFirstName             =. userFirstName
+        [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
-     -- , UserDisplayName           =. userDisplayName -- not updated, since users are allowed to change their DisplayName
+        [
-        , UserEmail                 =. userEmail
+        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 191
-        , UserTelephone             =. userTelephone
+          UserFirstName               =. userFirstName
-        , UserMobile                =. userMobile
+        , UserSurname                 =. userSurname
-        , UserCompanyPersonalNumber =. userCompanyPersonalNumber
+        , UserLastLdapSynchronisation =. Just now
-        , UserCompanyDepartment     =. userCompanyDepartment
+        , UserLdapPrimaryKey          =. userLdapPrimaryKey
-        , UserLastSync              =. Just now
+        , UserMobile                  =. userMobile
+        , UserTelephone               =. userTelephone
+        , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
+        , UserCompanyDepartment       =. userCompanyDepartment
         ]
     return (newUser, userUpdate)
 
   where
-    mbAzureData :: Maybe (Map Text [ByteString])
+    ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
-    mbAzureData = fmap (Map.fromListWith (++) . map (second (filter (not . ByteString.null)))) . concat $ preview _upsertUserAzureData <$> NonEmpty.toList upsertData
+    ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
-    mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString
-    mbLdapData = fmap (Map.fromListWith (++) . map (second (filter (not . ByteString.null)))) . concat $ preview _upsertUserLdapData <$> NonEmpty.toList upsertData
 
     -- just returns Nothing on error, pure
-    decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text
+    decodeLdap :: Ldap.Attr -> Maybe Text
-    decodeAzure azureData k = listToMaybe . rights $ Text.decodeUtf8' <$> azureData !!! k
+    decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
-    decodeLdap :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Maybe Text
-    decodeLdap ldapData attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapData !!! attr
 
-    -- decodeAzure' :: Map Text [ByteString] -> Text -> Text
+    decodeLdap' :: Ldap.Attr -> Text
-    -- decodeAzure' azureData = fromMaybe "" . decodeAzure azureData
+    decodeLdap' = fromMaybe "" . decodeLdap
-    -- decodeLdap' :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Text
-    -- decodeLdap' ldapData = fromMaybe "" . decodeLdap ldapData
     -- accept the first successful decoding or empty; only throw an error if all decodings fail
     -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
     -- decodeLdap' attr err
@@ -409,11 +342,11 @@ decodeUser now UserDefaultConf{..} upsertData = do
 
     -- only accepts the first successful decoding, ignoring all others, but failing if there is none
     -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
-    -- decodeLdap1 ldapData attr err
+    decodeLdap1 attr err
-    --     | (h:_) <- rights vs  = return h
+        | (h:_) <- rights vs  = return h
-    --     | otherwise           = throwM err
+        | otherwise           = throwM err
-    --   where
+      where
-    --     vs = Text.decodeUtf8' <$> (ldapData !!! attr)
+        vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
 
     -- accept and merge one or more successful decodings, ignoring all others
     -- decodeLdapN attr err
@@ -423,17 +356,6 @@ decodeUser now UserDefaultConf{..} upsertData = do
     --   where
     --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
 
-decodeUserTest :: ( MonadHandler m
-                  , HandlerSite m ~ UniWorX
-                  , MonadCatch m
-                  )
-               => NonEmpty UpsertUserData
-               -> m (Either DecodeUserException (User, [Update User]))
-decodeUserTest decodeData = do
-  now <- liftIO getCurrentTime
-  userDefaultConf <- getsYesod $ view _appUserDefaults
-  try $ decodeUser now userDefaultConf decodeData
-
 
 associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
 associateUserSchoolsByTerms uid = do
@@ -448,14 +370,11 @@ associateUserSchoolsByTerms uid = do
         , userSchoolIsOptOut = False
         }
 
-
+updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
-updateUserLanguage :: ( MonadHandler m
-                      , HandlerSite m ~ UniWorX
                       , YesodAuth UniWorX
                       , UserId ~ AuthId UniWorX
                       )
-                   => Maybe Lang
+                   => Maybe Lang -> SqlPersistT m (Maybe Lang)
-                   -> SqlPersistT m (Maybe Lang)
 updateUserLanguage (Just lang) = do
   unless (lang `elem` appLanguages) $
     invalidArgs ["Unsupported language"]
@@ -486,4 +405,7 @@ updateUserLanguage Nothing = runMaybeT $ do
   setRegisteredCookie CookieLang lang
   return lang
 
-embedRenderMessage ''UniWorX ''DecodeUserException id
+campusUserFailoverMode :: FailoverMode
+campusUserFailoverMode = FailoverUnlimited
+
+embedRenderMessage ''UniWorX ''CampusUserConversionException id

src/Handler/Admin.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 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
 
@@ -8,37 +8,65 @@ module Handler.Admin
 
 import Import
 
-import Jobs
 -- import Data.Either
-import qualified Data.Set as Set
+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 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.ExternalUser as Handler.Admin
+import Handler.Admin.Ldap as Handler.Admin
+
+-- avoids repetition of local definitions
+single :: (k,a) -> Map k a
+single = uncurry Map.singleton
 
 
+-- Types and Template Haskell
+data ProblemTableAction = ProblemTableMarkSolved
+                        | 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 :: Handler Html
+getAdminProblemsR, postAdminProblemsR :: Handler Html
-getAdminProblemsR = do 
+getAdminProblemsR = handleAdminProblems Nothing
+
+handleAdminProblems :: Maybe Widget -> Handler Html
+handleAdminProblems mbProblemTable = do
   now <- liftIO getCurrentTime
   let nowaday = utctDay now
       cutOffOldDays = 1
@@ -61,15 +89,16 @@ getAdminProblemsR = do
       <*> allRDriversHaveFs now
       <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime])
       <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
-      <*>  mkInterfaceLogTable flagError mempty
+      <*> 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
+    (Right (AvsLicenceDifferences{..},_)) -> do
       let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
-      forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday)
+      void $ runDB $ queueAvsUpdateByAID problemIds $ Just nowaday
       return $ Right
         ( Set.size avsLicenceDiffRevokeAll
         , Set.size avsLicenceDiffGrantVorfeld
@@ -78,7 +107,7 @@ getAdminProblemsR = do
         )
   -- 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 <$> retrieveDifferingLicences) `catches`
+  -- 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)
@@ -86,18 +115,61 @@ getAdminProblemsR = do
   --   ]
 
   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
 
-getProblemUnreachableR :: Handler Html
+    actUpdate markdone pids = do
-getProblemUnreachableR = 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 <- runDB 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>
@@ -148,8 +220,7 @@ mkUnreachableUsersTable = do
 -}
 
 areAllUsersReachable :: DB Bool
--- areAllUsersReachable = isNothing <$> E.selectOne retrieveUnreachableUsers'
+-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone
--- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers'
 areAllUsersReachable = null <$> retrieveUnreachableUsers
 
 -- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User))
@@ -167,10 +238,18 @@ 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.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
-    return $ filter hasInvalidEmail emailOnlyUsers
+    filterM hasInvalidEmail emailOnlyUsers
+    -- filterM hasInvalifPostal -- probably not worth it, since Utils.Postal.validPostAddress is pretty weak anyway
   where
-    hasInvalidEmail = isNothing . getEmailAddress . entityVal
+    hasInvalidEmail = fmap isNothing . getUserEmail
 
 
 allDriversHaveAvsId :: UTCTime -> DB Bool
@@ -234,7 +313,120 @@ retrieveDriversRWithoutF now = do
               `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.&&. (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 = mconcat
+      [ single ("time"  , SortColumn $ queryProblem >>> (E.^. ProblemLogTime))
+      , single ("info"  , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo))
+      -- , single ("firm"  , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo))))
+      , single ("firm"  , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company")
+      , single ("user"  , sortUserNameBareM queryUser)
+      , single ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved))
+      , single ("solver", sortUserNameBareM querySolver)
+      ]
+    dbtFilter = mconcat
+      [ single ("user"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser)   (E.?. UserDisplayName))
+      , single ("solver"  , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName))
+      , single ("company" , FilterColumn . E.mkContainsFilter  $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo)))
+      , single ("solved"  , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
+      -- , single ("problem" , FilterColumn . E.mkContainsFilter  $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext!
+      , single ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen
+          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 = mconcat
+      [ singletonMap ProblemTableMarkSolved   $ pure ProblemTableMarkSolvedData
+      , singletonMap 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

src/Handler/Admin/Avs.hs

@@ -9,7 +9,7 @@
 
 module Handler.Admin.Avs
   ( getAdminAvsR, postAdminAvsR
-  , getAdminAvsUserR
+  , getAdminAvsUserR, postAdminAvsUserR
   , getProblemAvsSynchR, postProblemAvsSynchR
   , getProblemAvsErrorR
   ) where
@@ -17,7 +17,7 @@ module Handler.Admin.Avs
 import Import
 import qualified Control.Monad.State.Class as State
 -- import Data.Aeson (encode)
-import qualified Data.Aeson.Encode.Pretty as Pretty
+-- import qualified Data.Aeson.Encode.Pretty as Pretty
 import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Set  as Set
@@ -27,9 +27,8 @@ import qualified Data.Map as Map
 import Handler.Utils
 import Handler.Utils.Avs
 -- import Handler.Utils.Qualification
-
+import Handler.Utils.Users (getUserPrimaryCompany)
-import Utils.Avs
+import Handler.Utils.Company (switchAvsUserCompany)
-
 
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Legacy as E
@@ -43,6 +42,13 @@ import qualified Database.Esqueleto.Utils        as E
 single :: (k,a) -> Map k a
 single = uncurry Map.singleton
 
+exceptionWgt :: SomeException -> Widget
+exceptionWgt (SomeException e) = [whamlet|<h2>Error:</h2> #{tshow e}|]
+
+tryShow :: MonadCatch m => m Widget -> m Widget
+tryShow act = try act >>= \case
+  Left  err -> return $ exceptionWgt err
+  Right res -> return res
 
 -- Button only needed in AVS TEST; further buttons see below
 data ButtonAvsTest = BtnCheckLicences   --  | BtnSynchLicences
@@ -53,7 +59,7 @@ instance Finite ButtonAvsTest
 nullaryPathPiece ''ButtonAvsTest camelToPathPiece
 
 instance Button UniWorX ButtonAvsTest where
-  btnLabel    BtnCheckLicences = "Check all licences"       -- could be msg
+  btnLabel    BtnCheckLicences = "Show all licence difference to current AVS"       -- could be msg
   -- btnLabel    BtnSynchLicences = "Synchronize all licences" -- could be msg
   btnClasses  BtnCheckLicences = [BCIsButton, BCPrimary]
   -- btnClasses  BtnSynchLicences = [BCIsButton, BCDanger]
@@ -87,7 +93,7 @@ validateAvsQueryPerson = do
     is _Just avsPersonQueryInternalPersonalNo ||
     is _Just avsPersonQueryVersionNo
 
-makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus
+makeAvsStatusForm :: Maybe AvsPersonId -> Form AvsQueryStatus
 makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
   flip (renderAForm FormStandard) html $
     parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
@@ -97,15 +103,15 @@ makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateA
       where
         nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
         ids = mapMaybe readMay nonemptys
-    unparseAvsIds :: AvsQueryStatus -> Text
+    unparseAvsIds :: AvsPersonId -> Text
-    unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
+    unparseAvsIds = tshow . avsPersonId
 
 validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler ()
 validateAvsQueryStatus = do
   AvsQueryStatus ids <- State.get
   guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
 
-makeAvsContactForm :: Maybe AvsQueryContact -> Form AvsQueryContact
+makeAvsContactForm :: Maybe AvsPersonId -> Form AvsQueryContact
 makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validateAvsQueryContact $ \html ->
   flip (renderAForm FormStandard) html $
     parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl) -- consider using cfAnySeparatedSet here
@@ -115,8 +121,9 @@ makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validat
       where
         nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
         ids = mapMaybe (fmap AvsObjPersonId . readMay) nonemptys
-    unparseAvsIds :: AvsQueryContact -> Text
+    unparseAvsIds :: AvsPersonId -> Text
-    unparseAvsIds (AvsQueryContact ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
+    unparseAvsIds = tshow . avsPersonId
+    --unparseAvsIds (AvsQueryContact ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
 
 validateAvsQueryContact :: FormValidator AvsQueryContact Handler ()
 validateAvsQueryContact = do
@@ -140,173 +147,270 @@ postAdminAvsR = do
   mbAvsConf <- getsYesod $ view _appAvsConf
   let avsWgt = [whamlet|
           $maybe avsConf <- mbAvsConf
-            AVS Konfiguration ist #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf}
+            <h2>
+              AVS Konfiguration
+            <ul>
+              <li>
+                Host:  #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf}
+              <li>
+                Timeout sekundäre AVS Abfragen: #{avsTimeout avsConf}s
+              <li>
+                Cache Gültigkeit sekundäre AVS Abfragen: #{tshow (avsCacheExpiry avsConf)}
           $nothing
             AVS nicht konfiguriert!
         |]
-  mAvsQuery <- getsYesod $ view _appAvsQuery
-  case mAvsQuery of
-    Nothing -> siteLayoutMsg MsgMenuAvs [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
-    Just AvsQuery{..} -> do
-      ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
 
-      let procFormPerson fr = do
+  ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
-            addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
-            res <- avsQueryPerson fr
-            case res of
-              Left  err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
-              Right (AvsResponsePerson pns) -> return $ Just [whamlet|
-                  <ul>
-                    $forall p <- pns
-                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
-                |]
-      mbPerson <- formResultMaybe presult procFormPerson
 
-      ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
+  let procFormPerson :: AvsQueryPerson -> Handler (Maybe (Maybe Widget, Maybe AvsPersonId))
-      let procFormStatus fr = do
+      procFormPerson (fixAvsQueryPerson -> fr) = do
-            addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
+        addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
-            res <- avsQueryStatus fr
+        try (avsQuery fr) >>= \case
-            case res of
+          Left err  -> return $ Just (Just $ exceptionWgt err, Nothing)
-              Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+          Right (AvsResponsePerson pns) -> do
-              Right (AvsResponseStatus pns) -> return $ Just [whamlet|
+            let mapid = case Set.toList pns of
-                  <ul>
+                          [AvsDataPerson{avsPersonPersonID=apid}] -> Just apid
-                    $forall p <- pns
+                          _ -> Nothing
-                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
+                wgt = [whamlet|
-                |]
-      mbStatus <- formResultMaybe sresult procFormStatus
-
-      ((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
-      let procFormContact fr = do
-            addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
-            res <- avsQueryContact fr
-            case res of
-              Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
-              Right (AvsResponseContact pns) -> return $ Just [whamlet|
-                  <ul>
-                    $forall AvsDataContact{..} <- pns
-                      <li>
                         <ul>
-                          <li>AvsId: #{tshow avsContactPersonID}
+                          $forall p <- pns
-                          <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
+                            <li>^{jsonWidget p}
-                          <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))}
+                      |] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
-                |]
+            return $ Just (toMaybe (notNull pns) wgt, mapid)
-      mbContact <- formResultMaybe cresult procFormContact
+  (mbPerson,mapid) <- fromMaybe (Nothing,Nothing) <$> formResultMaybe presult procFormPerson
 
+  ((sresult', swidget), senctype) <- runFormPost $ makeAvsStatusForm mapid
+  let sresult = sresult' <|> maybe FormMissing (FormSuccess . AvsQueryStatus . Set.singleton) mapid -- use unique AvsId from PersonSearch for convenience, if form was empty
+      procFormStatus fr = do
+        addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
+        tryShow $ do
+          AvsResponseStatus pns <- avsQuery fr
+          return [whamlet|
+              <ul>
+                $forall p <- pns
+                  <li>^{jsonWidget p}
+            |]
+  mbStatus <- formResultMaybe sresult (Just <<$>> procFormStatus)
 
-      ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
+  ((cresult', cwidget), cenctype) <- runFormPost $ makeAvsContactForm mapid
-        flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
+  let cresult = cresult' <|> maybe FormMissing (FormSuccess . AvsQueryContact . Set.singleton . AvsObjPersonId) mapid -- use unique AvsId from PersonSearch for convenience, if form was empty
-      let procFormCrUsr fr = do
+      procFormContact fr = do
-            -- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
+        addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
-            res <- try $ guessAvsUser fr
+        tryShow $ do
-            case res of
+          AvsResponseContact pns <- avsQuery fr
-              (Right (Just uid)) -> do
+          return [whamlet|
-                uuid :: CryptoUUIDUser <- encrypt uid
+              <ul>
-                return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
+                $forall AvsDataContact{..} <- pns
-              (Right Nothing) ->
+                  <li>
-                return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
-              (Left e) -> do
-                let msg = tshow (e :: SomeException)
-                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
-      mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
-
-      ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
-        flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
-                                                    <*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
-                                                    <*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
-      let procFormGetLic fr = do
-            res <- avsQueryGetAllLicences
-            case res of
-              (Right (AvsResponseGetLicences lics)) -> do
-                let flics = Set.toList $ Set.filter lfltr lics
-                    lfltr = case fr of -- not pretty, but it'll do
-                      (Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
-                      (Just idmin, Nothing,    Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
-                      (Nothing   , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
-                      (Nothing   , Nothing,    Just lic) -> \AvsPersonLicence{..} ->  avsLicenceRampLicence == lic
-                      (Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
-                      (Just idmin, Nothing,    Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
-                      (Nothing   , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
-                      (Nothing   , Nothing,    Nothing ) -> const True
-                addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
-                return $ Just [whamlet|
-                    <h2>Success:</h2>
                     <ul>
-                      $forall AvsPersonLicence{..} <- flics
+                      <li>AvsId: #{tshow avsContactPersonID}
-                        <li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
+                      <li>^{jsonWidget avsContactPersonInfo}
-                  |]
+                      <li>^{jsonWidget avsContactFirmInfo}
-
+            |] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
-              (Left err) -> do
+  mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)
-                let msg = tshow err
-                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
-      mbGetLic <- formResultMaybe getLicRes procFormGetLic
-
-      ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
-        flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
-                                                   <*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
-      let procFormSetLic (aid, lic) = do
-            res <- try $ setLicenceAvs (AvsPersonId aid) lic
-            case res of
-              (Right True) ->
-                return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
-              (Right False) ->
-                return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
-              (Left e) -> do
-                let msg = tshow (e :: SomeException)
-                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
-      mbSetLic <- formResultMaybe setLicRes procFormSetLic
 
 
-      (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
+  ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
-      mbQryLic <- case qryLicRes of
+    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
-        Nothing -> return Nothing
+  let procFormCrUsr fr = do
-        (Just BtnCheckLicences) -> do
+        -- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
-          res <- try $ do
+        res <- try $ guessAvsUser fr
-            allLicences <- throwLeftM avsQueryGetAllLicences
+        case res of
-            computeDifferingLicences allLicences
+          (Right (Just uid)) -> do
-          case res of
+            uuid :: CryptoUUIDUser <- encrypt uid
-            (Right diffs) -> do
+            return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
-              let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
+          (Right Nothing) ->
-                  r_grant = showLics AvsLicenceRollfeld
+            return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
-                  f_set   = showLics AvsLicenceVorfeld
+          (Left e) -> return $ Just $ exceptionWgt e
-                  revoke  = showLics AvsNoLicence
+  mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
-              return $ Just [whamlet|
+
-                  <h2>Licence check differences:
+  ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
-                  <h3>Grant R:
+    flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
-                  <p>
+                                                <*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
-                    #{r_grant}
+                                                <*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
-                  <h3>Set to F:
+  let procFormGetLic fr = tryShow $ do
-                  <p>
+        AvsResponseGetLicences lics <- avsQuery AvsQueryGetAllLicences
-                    #{f_set}
+        let flics = Set.toList $ Set.filter lfltr lics
-                  <h3>Revoke licence:
+            lfltr = case fr of -- not pretty, but it'll do
-                  <p>
+                (Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
-                    #{revoke}
+                (Just idmin, Nothing,    Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
+                (Nothing   , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
+                (Nothing   , Nothing,    Just lic) -> \AvsPersonLicence{..} ->  avsLicenceRampLicence == lic
+                (Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
+                (Just idmin, Nothing,    Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
+                (Nothing   , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
+                (Nothing   , Nothing,    Nothing ) -> const True
+        addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
+        return [whamlet|
+              <h2>Success:</h2>
+              <ul>
+                $forall AvsPersonLicence{..} <- flics
+                  <li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
+            |]
+  mbGetLic <- formResultMaybe getLicRes (Just <<$>> procFormGetLic)
+
+  ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
+    flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
+                                                <*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
+  let procFormSetLic (aid, lic) = do
+        res <- try $ setLicenceAvs (AvsPersonId aid) lic
+        case res of
+          (Right True) ->
+            return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
+          (Right False) ->
+            return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
+          (Left e) -> do
+            let msg = tshow (e :: SomeException)
+            return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+  mbSetLic <- formResultMaybe setLicRes procFormSetLic
+
+
+  (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
+  (mbQryLic :: Maybe Widget, mbAutoDiffs :: Maybe Html) <- case qryLicRes of
+    Nothing -> return mempty
+    (Just BtnCheckLicences) -> do
+      res <- try $ do
+        allLicences <- avsQueryNoCache AvsQueryGetAllLicences
+        computeDifferingLicences allLicences
+      basediffs <- case res of
+        (Right diffs) -> do
+          let showLics l =
+                let chgs = Set.filter ((l ==) . avsLicenceRampLicence) diffs
+                in if Set.null chgs
+                    then ("[ ]", 0)
+                    else (Text.intercalate ", " (tshow . avsLicencePersonID <$> Set.toList chgs), Set.size chgs)
+              (r_grant, rg_size) = showLics AvsLicenceRollfeld
+              (f_set  , fs_size) = showLics AvsLicenceVorfeld
+              (revoke , rv_size) = showLics AvsNoLicence
+          return $ Just [whamlet|
+              <h2>Licence check AVS-ID differences:
+              <dl .deflist>
+                <dt .deflist__dt>Grant R (#{rg_size}):
+                <dd .deflist__dd>#{r_grant}
+
+                <dt .deflist__dt>Set to F (#{fs_size}):
+                <dd .deflist__dd>#{f_set}
+
+                <dt .deflist__dt>Revoke licence (#{rv_size}):
+                <dd .deflist__dd>#{revoke}
+            |]
+        (Left e) -> do
+          let msg = tshow (e :: SomeException)
+          return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
+      autoDiffs <- do
+        -- what follows is copy of the code from Jobs.Handler.SynchroniseAvs.dispatchJobSynchroniseAvsLicences modified to not do anything actually
+        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
+        guardMonoidM (synchLevel > 0) $ do
+          let showApids apids
+                | null apids = "[ ]"
+                | otherwise = Text.intercalate ", " (tshow <$> Set.toList apids)
+              procLic :: (Ord a, Show a) => AvsLicence -> Bool -> Set a -> Html
+              procLic aLic up apids
+                | n <- Set.size apids, n > 0 =
+                  let subtype   = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
+                  in if NTop (Just n) <= NTop maxChanges
+                      then
+                        [shamlet|
+                          <dt .deflist__dt>#{subtype} (#{n}):
+                          <dd .deflist__dd>#{showApids apids}
+                        |]
+                      else
+                        [shamlet|
+                          <dt .deflist__dt>#{subtype} (#{n}):
+                          <dd .deflist__dd>Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}
+                        |]
+                | otherwise = mempty
+
+          (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) <- X.from $ E.table @UserAvs
+                `E.innerJoin` E.table @QualificationUser      `X.on` (\( uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
+                `E.innerJoin` E.table @QualificationUserBlock `X.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
+
+              l1 = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence       False $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
+              l2 = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld
+              l3 = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld  False $ fltrIds avsLicenceDiffRevokeRollfeld   --downgrade Rollfeld -> Vorfeld
+              l4 = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True  $ fltrIds avsLicenceDiffGrantRollfeld    --grant     Rollfeld
+              avsIdChanges = [shamlet|
+                  <h3>
+                    Next automatic AVS-ID licence synchronisation:
+                  <dl .deflist>
+                    ^{l4}
+                    ^{l3}
+                    ^{l2}
+                    ^{l1}
+                    $maybe reason <- reasonFilter
+                      <dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
+                      <dd .deflist__dd>#{showApids reasonFltrdIds}
                 |]
-            (Left e) -> do
+          ----------------------------------------------------
-              let msg = tshow (e :: SomeException)
+          -- translate AVS-IDs to AVS-NOs for convenience only
-              return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
+          avsidnos <- runDBRead $ E.select $ do
-        -- (Just BtnSynchLicences) -> do
+            ua <- X.from $ E.table @UserAvs
-        --   res <- try synchAvsLicences
+            E.where_ $ ua E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld]) -- , reasonFltrdIds])
-        --   case res of
+            return (ua E.^. UserAvsPersonId, ua E.^. UserAvsNoPerson)
-        --     (Right True) ->
+          let id2no = Map.fromList $ $(E.unValueN 2) <$> avsidnos
-        --       return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
+              translate = setMapMaybe (`Map.lookup` id2no)
-        --     (Right False) ->
+              l1' = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence       False $ translate $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
-        --       return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
+              l2' = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ translate $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld
-        --     (Left e) -> do
+              l3' = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld  False $ translate $ fltrIds avsLicenceDiffRevokeRollfeld   --downgrade Rollfeld -> Vorfeld
-        --       let msg = tshow (e :: SomeException)
+              l4' = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True  $ translate $ fltrIds avsLicenceDiffGrantRollfeld    --grant     Rollfeld
-        --       return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
+              autoNoDiffs =  [shamlet|
+                  <h3>
+                    Next automatic licence changes translated to human readable AVS-Numbers, if known:
+                  <dl .deflist>
+                    ^{l4'}
+                    ^{l3'}
+                    ^{l2'}
+                    ^{l1'}
+                    $maybe reason <- reasonFilter
+                      <dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
+                      <dd .deflist__dd>#{showApids $ translate reasonFltrdIds}
+                |]
+          return $ Just $ avsIdChanges <> autoNoDiffs
+      return (basediffs, autoDiffs)
 
-      actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
+    -- (Just BtnSynchLicences) -> do
-      siteLayoutMsg MsgMenuAvs $ do
+    --   res <- try synchAvsLicences
-        setTitleI MsgMenuAvs
+    --   case res of
-        let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
+    --     (Right True) ->
-            personForm  = wrapFormHere pwidget  penctype
+    --       return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
-            statusForm  = wrapFormHere swidget  senctype
+    --     (Right False) ->
-            contactForm = wrapFormHere cwidget  cenctype
+    --       return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
-            crUsrForm   = wrapFormHere crUsrWgt crUsrEnctype
+    --     (Left e) -> do
-            getLicForm  = wrapFormHere getLicWgt getLicEnctype
+    --       let msg = tshow (e :: SomeException)
-            setLicForm  = wrapFormHere setLicWgt setLicEnctype
+    --       return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
-        -- TODO: use i18nWidgetFile instead if this is to become permanent
+
-        $(widgetFile "avs")
+  actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
+  siteLayoutMsg MsgMenuAvs $ do
+    setTitleI MsgMenuAvs
+    let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
+        personForm  = wrapFormHere pwidget  penctype
+        statusForm  = wrapFormHere swidget  senctype
+        contactForm = wrapFormHere cwidget  cenctype
+        crUsrForm   = wrapFormHere crUsrWgt crUsrEnctype
+        getLicForm  = wrapFormHere getLicWgt getLicEnctype
+        setLicForm  = wrapFormHere setLicWgt setLicEnctype
+    -- TODO: use i18nWidgetFile instead if this is to become permanent
+    $(widgetFile "avs")
 
 {-
 
@@ -369,8 +473,8 @@ postProblemAvsSynchR = getProblemAvsSynchR
 getProblemAvsSynchR = do
   let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r)
       catchAllAvs    = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload; do not call redirect within catchAllAvs actions!
-  (AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
+  ((AvsLicenceDifferences{..}, rsChanged), apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
-
+  let mkLicTbl = mkLicenceTable apidStatus rsChanged
   --
   unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->
     runDB $ E.select $ do
@@ -383,7 +487,7 @@ getProblemAvsSynchR = do
       numUnknownLicenceOwners = length unknownLicenceOwners
 
   (btnImportUnknownWgt, btnImportUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsImportUnknown
-  ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do
+  ifNothingM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do
     res <- catchAllAvs $ forM (take 500 unknownLicenceOwners) $ try . upsertAvsUserById -- TODO: turn this into a background job
     let procRes (Right _)                           = (Sum 1, mempty :: Set.Set AvsPersonId, mempty :: Set.Set AvsPersonId, mempty)
         --TODO: continue here!
@@ -414,7 +518,7 @@ getProblemAvsSynchR = do
             ^{revokeUnknownExecWgt}
         |]
 
-  ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do
+  ifNothingM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do
     let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners
         no_revokes = Set.size revokes
     oks <- catchAllAvs $ setLicencesAvs revokes
@@ -425,10 +529,10 @@ getProblemAvsSynchR = do
 
   -- licence differences
   ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,)
-          <$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll
+          <$> mkLicTbl "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll
-          <*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld
+          <*> mkLicTbl "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld
-          <*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld
+          <*> mkLicTbl "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld -- downgrade to Vorfeld
-          <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld
+          <*> mkLicTbl "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld
 
   now <- liftIO getCurrentTime
   let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
@@ -441,8 +545,8 @@ getProblemAvsSynchR = do
 
       procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do
         oks <- runDB $ do
-          qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic
+          qIds <- selectKeysList [QualificationAvsLicence ==. Just alic] []          -- sanity check
-          if qId /= licenceTableChangeFDriveQId
+          if licenceTableChangeFDriveQId `notElem` qIds
             then return (-1)
             else do
               uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
@@ -467,6 +571,7 @@ getProblemAvsSynchR = do
   formResult tres1up    $ procRes AvsLicenceVorfeld
   formResult tres0      $ procRes AvsNoLicence
 
+  AvsLicenceSynchConf{..} <- getsYesod $ view _appAvsLicenceSynchConf
   siteLayoutMsg MsgAvsTitleLicenceSynch $ do
     setTitleI   MsgAvsTitleLicenceSynch
     $(i18nWidgetFile "avs-synchronisation")
@@ -519,14 +624,17 @@ instance HasUser LicenceTableData where
 -- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser
 --   hasQualificationUser = resultQualUser . _entityVal
 
-mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
+mkLicenceTable :: AvsPersonIdMapPersonCard -> Set AvsPersonId -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
-mkLicenceTable apidStatus dbtIdent aLic apids = do
+mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do
-  currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
+  (currentRoute, usrHasAvsRerr) <- liftHandler $ (,)
-  avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
+    <$> (fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute)
+    <*> (messageTooltip <$> messageI Error MsgProblemAvsUsrHadR)
+  avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [Asc QualificationName]
   now <- liftIO getCurrentTime
 
   let nowaday = utctDay now
       avsQids = entityKey <$> avsQualifications
+      qualOpts = pure $ qualificationsOptionList avsQualifications
       -- fltrLic qual = if
       --   | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence)         -- could be R, F, both or none at all, but has licence in AVS
       --   | otherwise            -> E.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too
@@ -551,7 +659,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
         , sortable (Just "avspersonno")  (i18nCell MsgAvsPersonNo)    $ \(view  resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a
         -- , colUserCompany
         , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
-            companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
+            companies' <- liftHandler . runDBRead . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
               E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
               E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
               E.orderBy [E.asc (comp E.^. CompanyName)]
@@ -561,7 +669,18 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
                   (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
 
             pure $ intercalate (text2widget "; ") companies
-        , sortable (Just "qualification") (i18nCell MsgTableQualifications)          $ \(preview   resultQualification -> q) -> cellMaybe lmsShortCell q
+        , sortable (Just "qualification") (i18nCell MsgTableQualifications) $
+            if aLic /= AvsLicenceVorfeld
+              then
+                \(preview   resultQualification -> q) -> cellMaybe lmsShortCell q
+              else
+                \row ->
+                  let q       = row ^? resultQualification
+                      apid    = row ^. resultUserAvs . _userAvsPersonId
+                      warnCell c = if Set.member apid rsChanged
+                        then c <> spacerCell <> wgtCell usrHasAvsRerr    -- expected to be effectively dead code in practice, but we never know
+                        else c
+                  in warnCell $ cellMaybe lmsShortCell q
         , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> cellMaybe dayCell d
         , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> cellMaybe dayCell d
         -- , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> cellMaybe dayCell d
@@ -605,14 +724,6 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
         , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
         ]
 
-      qualOpt :: Entity Qualification -> Handler (Option QualificationId)
-      qualOpt (Entity qualId qual) = do
-        cQualId :: CryptoUUIDQualification <- encrypt qualId
-        return $ Option
-          { optionDisplay       = CI.original $ qualificationName qual
-          , optionInternalValue = qualId
-          , optionExternalValue = tshow cQualId
-          }
       aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications
 
       -- Block identical to Handler/Qualifications TODO: refactor
@@ -630,20 +741,20 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
       mkOption :: E.Value Text -> Option Text
       mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
       suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
-      suggestionsBlock   = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
+      suggestionsBlock   = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not__)
-      suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
+      suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id)
 
       acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
       acts = mconcat
           [ singletonMap LicenceTableChangeAvs    $ pure LicenceTableChangeAvsData
           , if aLic == AvsNoLicence
               then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
-                    <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
+                    <$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
                     <*> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationBlockReason) Nothing
                     <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant)       (fslI MsgQualificationBlockNotify) (Just False)
 
               else singletonMap LicenceTableGrantFDrive  $ LicenceTableGrantFDriveData
-                    <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
+                    <$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
                     <*> apreq (textField & cfStrip & addDatalist suggestionsUnblock)  (fslI MsgQualificationGrantReason) Nothing
                     <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
                     <*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing
@@ -677,52 +788,204 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
 
 
 
-getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
+data UserAvsAction = UserAvsSwitchCompany
-getAdminAvsUserR uuid = do
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-  uid <- decrypt uuid
+  deriving anyclass (Universe, Finite)
-  Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
+
-  mAvsQuery <- getsYesod $ view _appAvsQuery
+nullaryPathPiece ''UserAvsAction $ camelToPathPiece' 1
-  resWgt <- case mAvsQuery of
+embedRenderMessage ''UniWorX ''UserAvsAction id
-    Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
+instance Button UniWorX UserAvsAction where
-    Just AvsQuery{..} -> do
+  btnClasses UserAvsSwitchCompany = [BCIsButton, BCDefault]
-      mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
+
-      mbDataPerson <- lookupAvsUser userAvsPersonId
+
-      return [whamlet|
+getAdminAvsUserR,  postAdminAvsUserR :: CryptoUUIDUser -> Handler Html
+getAdminAvsUserR = postAdminAvsUserR
+postAdminAvsUserR uuid = do
+    isModal <- hasCustomHeader HeaderIsModal
+
+    uid <- decrypt uuid
+    Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
+    -- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
+    let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID))
+        -- fltrIdStatus  = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
+    mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
+    -- mbStatus  <- try $ fmap fltrIdStatus  $ avsQuery $ AvsQueryStatus  $ Set.singleton                  userAvsPersonId
+    mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses
+    let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
+    compDict <- if 1 >= length compsUsed
+      then return mempty -- switch company only sensible if there is more than one company to choose
+      else do
+        let switchCompFormHandler :: [(CompanyName,CompanyId)] -> Maybe CompanyId -> Handler Widget
+            switchCompFormHandler availComps      _  | 1 >= length availComps = return mempty    -- don't offer a form if there is only one company
+            switchCompFormHandler availComps mbPrime = do
+                let switchCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyId)
+                    switchCompForm = (,)
+                      <$> apopt hiddenField "" (Just uuid)
+                      <*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) (fslI MsgUserAvsSwitchCompanyField) mbPrime
+                      <*  aopt (buttonField UserAvsSwitchCompany) "" Nothing
+                    switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler ()
+                    switchCompValidate = do
+                      (uuid_rcvd,_) <- State.get
+                      guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
+                ((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm
+                formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do
+                    lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
+                    problems <- liftHandler . runDB $ do
+                      (usrUp, problems) <- switchAvsUserCompany True False uid cid
+                      update uid usrUp
+                      forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p
+                    forM_ problems (\p -> do
+                        -- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages
+                        tell . pure =<< messageI Warning p
+                      )
+                    let ok = if null problems then Success else Error
+                    tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid)
+                  )
+                return $ wrapForm spWgt
+                  def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]}
+        (availComps, primName, primId) <- runDB $ do
+          mbPrimeUsrComp :: Maybe UserCompany <- getUserPrimaryCompany uid
+          mbPrimeComp :: Maybe Company <- traverseJoin (get . userCompanyCompany) mbPrimeUsrComp
+          -- let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort])
+          comps :: [Entity Company] <- selectList [CompanyName <-. compsUsed]  [Asc CompanyName, Asc CompanyAvsId] -- company name is already unique, but AVS sometimes contains uses whitespace
+          return ([(companyName v, k) | (Entity k v) <- comps], companyName <$> mbPrimeComp, CompanyKey . companyShorthand <$> mbPrimeComp)
+        -- formDict <- Map.traverseWithKey runSwitchFrom compDict
+        swForm <- switchCompFormHandler availComps primId
+        return (primName, swForm)
+
+    msgWarningTooltip <- messageI Warning MsgMessageWarning
+    let warnBolt = messageTooltip msgWarningTooltip
+        heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
+    siteLayout heading $ do
+      setTitle $ toHtml $ show userAvsNoPerson
+      let contactWgt = case mbContact of
+            Left err -> exceptionWgt err
+            Right (AvsResponseContact adcs) ->
+              if null adcs
+                then [whamlet|_{MsgAvsPersonSearchEmpty}|]
+                else
+                  let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
+                  in  mconcat cs
+          cardsWgt = case mbStatus of
+            Left err -> exceptionWgt err
+            Right (AvsResponseStatus asts) ->
+              if null asts
+                then [whamlet|_{MsgAvsStatusSearchEmpty}|]
+                else
+                  let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts
+                  in mconcat cs
+      [whamlet|
         <p>
-          Vorläufige Admin Ansicht AVS Daten.
+          ^{contactWgt}
-          Ansicht zeigt aktuelle Daten.
-          Es erfolgte damit aber noch kein Update der FRADrive Daten.
         <p>
-          <dl .deflist>
+          ^{cardsWgt}
-            <dt .deflist__dt>InfoPersonContact <br>
+        <p>
-              <i>(bevorzugt)
+          _{MsgAvsCurrentData}
+      |]
+  where
+    mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
+    mkContactWgt warnBolt reqAvsNo AvsDataContact
+      { -- avsContactPersonID = _api
+        avsContactPersonInfo = AvsPersonInfo{..}
+      , avsContactFirmInfo   = AvsFirmInfo{ avsFirmFirm = firmName }
+      } =
+      let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
+      [whamlet|
+        <section .profile>
+          <dl .deflist.profile-dl>
+            $if avsNoOk
+              <dt .deflist__dt>
+                _{MsgAvsPersonNo}
+              <dd .deflist__dd>
+                #{avsInfoPersonNo}
+                ^{warnBolt}
+                _{MsgAvsPersonNoMismatch}
+            <dt .deflist__dt>
+              _{MsgAvsLastName}
             <dd .deflist__dd>
-              $case mbContact
+              #{avsInfoLastName}
-                $of Left err
+            <dt .deflist__dt>
-                  Fehler: #{tshow err}
+              _{MsgAvsFirstName}
-                $of Right contactInfo
-                  #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
-            <dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
-              <i>(benötigt mehrere AVS Abfragen)
             <dd .deflist__dd>
-              $maybe dataPerson <- mbDataPerson
+              #{avsInfoFirstName}
-                #{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
+            <dt .deflist__dt>
+              _{MsgAvsPrimaryCompany}
+            <dd .deflist__dd>
+              #{firmName}
+            $maybe bday <- avsInfoDateOfBirth
+              <dt .deflist__dt>
+                _{MsgAdminUserBirthday}
+              <dd .deflist__dd>
+                ^{formatTimeW SelFormatDate bday}
+            <dt .deflist__dt>
+              _{MsgAvsLicence}
+            <dd .deflist__dd>
+              $maybe licence <- parseAvsLicence avsInfoRampLicence
+                _{licence}
               $nothing
-                Keine Daten erhalten.
+                _{MsgAvsNoLicenceGuest}
-        <h3>
+      |]
-          Provisorische formatierte Ansicht
+
-        <p>
+    -- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget
-          Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte.
+    mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget
-          In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar.
+    mkCardsWgt (mbPrimName, swForm) crds
-        <p>
+      | null crds = [whamlet|_{MsgAvsCardsEmpty}|]
-          ^{foldMap jsonWidget mbContact}
+      | otherwise = do
-        <p>
+        let hasCompany     = isJust $ Set.foldr ((<|>) . avsDataFirm)       Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does
-          ^{foldMap jsonWidget mbDataPerson}
+            hasIssueDate   = isJust $ Set.foldr ((<|>) . avsDataIssueDate)  Nothing crds
+            hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo)    Nothing crds
+        [whamlet|
+          <div .scrolltable .scrolltable-bordered>
+            <table .table .table--striped>
+              <thead>
+                <tr .table__row .table__row--head>
+                  <th .table__th>_{MsgAvsCardNo}
+                  <th .table__th>_{MsgTableAvsCardValid}
+                  <th .table__th>_{MsgAvsCardColor}
+                  <th .table__th>_{MsgAvsCardAreas}
+                  $if hasIssueDate
+                    <th .table__th>_{MsgTableAvsCardIssueDate}
+                  $if hasValidToDate
+                    <th .table__th>_{MsgTableAvsCardValidTo}
+                  $if hasCompany
+                    <th .table__th>_{MsgTableCompany}
+                    <th .table__th>_{MsgAvsPrimaryCompany}
+              <tbody>
+                $forall c <- Set.toDescList crds
+                  $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
+                    <tr .table__row>
+                      <td .table__td>
+                        #{tshowAvsFullCardNo (getFullCardNo c)}
+                      <td .table__td>
+                        #{boolSymbol avsDataValid}
+                      <td .table__td>
+                        _{avsDataCardColor}
+                      <td .table__td>
+                        $forall a <- avsDataCardAreas
+                          #{a} #
+                      $if hasIssueDate
+                        <td .table__td>
+                          $maybe d <- avsDataIssueDate
+                            ^{formatTimeW SelFormatDate d}
+                      $if hasValidToDate
+                        <td .table__td>
+                          $maybe d <- avsDataValidTo
+                            ^{formatTimeW SelFormatDate d}
+                      $if hasCompany
+                        <td .table__td>
+                          $maybe f <- avsDataFirm
+                            #{f}
+                        <td .table__td>
+                          $maybe f <- avsDataFirm
+                            $with fci <- stripCI f
+                              $maybe primName <- mbPrimName
+                                $if (primName == fci)
+                                  _{MsgAvsPrimaryCompany}
+            <p>
+              ^{swForm}
         |]
-  let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
+
-  siteLayout heading $ do
+
-    setTitle $ toHtml $ show userAvsNoPerson
-    resWgt
 
 instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where
   hasEntity = _dbrOutput . _2
@@ -740,7 +1003,7 @@ getProblemAvsErrorR = do
         dbtSQLQuery (usravs `E.InnerJoin` user) = do
           E.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId
           E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError
-          return (usravs, user)
+          return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring
         qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
         qerryUsrAvs   = $(E.sqlIJproj 2 1)
         qerryUser   :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
@@ -788,4 +1051,3 @@ getProblemAvsErrorR = do
   siteLayoutMsg MsgMenuAvsSynchError $ do
     setTitleI MsgMenuAvsSynchError
     [whamlet|^{avsSyncErrTbl}|]
-    

src/Handler/Admin/Crontab.hs

@@ -35,6 +35,9 @@ import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 -- import Database.Esqueleto.Utils.TH
 
+-- Number of minutes a job must have been locked already to allow forced deletion
+jobDeleteLockMinutes :: Int
+jobDeleteLockMinutes = 3 
 
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 1
@@ -118,7 +121,9 @@ instance Finite JobTableAction
 nullaryPathPiece ''JobTableAction $ camelToPathPiece' 1
 embedRenderMessage ''UniWorX ''JobTableAction id
 
-data JobTableActionData = ActJobDeleteData
+newtype JobTableActionData = ActJobDeleteData 
+                            { jobDeleteLocked :: Bool
+                            }
   deriving (Eq, Ord, Read, Show, Generic)
 
 
@@ -164,7 +169,8 @@ postAdminJobsR = do
           ]
         dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
         acts :: Map JobTableAction (AForm Handler JobTableActionData)
-        acts = Map.singleton ActJobDelete $ pure ActJobDeleteData
+        acts = Map.singleton ActJobDelete $ ActJobDeleteData
+                <$> areq checkBoxField (fslI $ MsgActJobDeleteForce jobDeleteLockMinutes) Nothing
         dbtParams = DBParamsForm 
           { dbParamsFormAdditional = 
             renderAForm FormStandard
@@ -193,13 +199,22 @@ postAdminJobsR = do
   (jobActRes, jobsTable) <- runDB (over _1 postprocess <$> dbTable jobsDBTableValidator jobsDBTable)
 
   formResult jobActRes $ \case
-    (ActJobDeleteData, jobIds) -> do
+    (ActJobDeleteData{jobDeleteLocked}, jobIds) -> do
-      let jobReq  = length jobIds
+      now <- liftIO getCurrentTime
+      let cutoff :: UTCTime
+          cutoff = addUTCTime (nominalMinute * fromIntegral (negate jobDeleteLockMinutes)) now
+          jobReq    = length jobIds
+          lockCriteria
+            | jobDeleteLocked = 
+                [ QueuedJobLockTime ==. Nothing ] ||.
+                [ QueuedJobLockTime <=. Just cutoff ]
+            | otherwise = 
+                [ QueuedJobLockTime     ==. Nothing
+                , QueuedJobLockInstance ==. Nothing
+                ]
       rmvd <- runDB $ fromIntegral <$> deleteWhereCount
-        [ QueuedJobLockTime ==. Nothing
+        ((QueuedJobId <-. Set.toList jobIds) : lockCriteria)
-        , QueuedJobLockInstance ==. Nothing
+        
-        , QueuedJobId <-. Set.toList jobIds
-        ]
       addMessageI (bool Success Warning $ rmvd < jobReq) (MsgTableJobActDeleteFeedback rmvd jobReq)
       reloadKeepGetParams AdminJobsR
 

src/Handler/Admin/ExternalUser.hs

@@ -1,74 +0,0 @@
--- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Handler.Admin.ExternalUser
-  ( getAdminExternalUserR
-  , postAdminExternalUserR
-  ) where
-
-import Import
-
-import Foundation.Yesod.Auth (userLookupAndUpsert) -- decodeUserTest
-import Auth.OAuth2 (queryOAuth2User)
-import Auth.LDAP
-
-import Handler.Utils
-
-import Data.Aeson.Encode.Pretty (encodePretty)
-import qualified Data.Text.Lazy as Lazy
-import qualified Data.Text.Lazy.Encoding as Lazy
-
-
-getAdminExternalUserR,  postAdminExternalUserR :: Handler Html
-getAdminExternalUserR = postAdminExternalUserR
-postAdminExternalUserR = do
-  ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminExternalUserLookup"::Text) $ \html -> 
-    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
-
-  let
-    -- presentUtf8   v = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> v)
-    -- presentLatin1 v = Text.intercalate ", " (                 Text.decodeLatin1 <$> v)
-
-    procFormPerson :: Text -> Handler (Maybe [(AuthSourceIdent,Lazy.Text)]) -- (Maybe [(AuthSourceIdent, [(Text,(Int,Text,Text))])])
-    procFormPerson needle = getsYesod (view _appUserAuthConf) >>= \case
-      UserAuthConfSingleSource{..} -> case userAuthConfSingleSource of
-        AuthSourceConfAzureAdV2 AzureConf{..} -> do
-          -- only singleton results supported right now, i.e. lookups by email, userPrincipalName (aka fraport ident), or id
-          queryOAuth2User @Value needle >>= \case
-            Left _ -> addMessage Error (text2Html "Encountered UserDataException while Azure user query!") >> return Nothing
-            Right azureResponse -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) . Lazy.decodeUtf8 $ encodePretty azureResponse
-            -- Right azureData -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) $ azureData <&> \(k,vs) -> (k, (length vs, presentUtf8 vs, presentLatin1 vs))
-        AuthSourceConfLdap LdapConf{..} -> do
-          getsYesod (view _appLdapPool) >>= \case
-            Nothing -> addMessage Error (text2Html "LDAP Pool configuration missing!") >> return Nothing
-            Just pool -> do
-              ldapData <- ldapSearch pool needle
-              -- decodedErr <- decodeUserTest $ NonEmpty.singleton UpsertUserDataLdap{ upsertUserLdapHost = ldapConfSourceId, upsertUserLdapData = concat ldapData }
-              -- whenIsLeft decodedErr $ addMessageI Error
-              return . Just . singleton . (AuthSourceIdLdap ldapConfSourceId,) . Lazy.decodeUtf8 $ encodePretty ldapData
-              -- return . Just $ ldapData <&> \(Ldap.SearchEntry _dn attrs) -> (AuthSourceIdLdap{..}, (\(k,v) -> (tshow k, (length v, presentUtf8 v, presentLatin1 v))) <$> attrs)
-
-  mbData <- formResultMaybe presult procFormPerson
-
-
-  ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminExternalUserUpsert"::Text) $ \html -> 
-    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
-  let procFormUpsert :: Text -> Handler (Maybe (Entity User))
-      procFormUpsert lid = runDB (userLookupAndUpsert lid UpsertUserGuessUser)
-
-  mbUpsert <- formResultMaybe uresult procFormUpsert
-
-
-  actionUrl <- fromMaybe AdminExternalUserR <$> getCurrentRoute
-  siteLayoutMsg MsgMenuExternalUser $ do
-    setTitleI MsgMenuExternalUser
-    let personForm = wrapForm pwidget def
-                      { formAction = Just $ SomeRoute actionUrl
-                      , formEncoding = penctype
-                      }
-        upsertForm = wrapForm uwidget def 
-                      { formAction = Just $ SomeRoute actionUrl
-                      , formEncoding = uenctype
-                      }
-    $(widgetFile "admin/external-user")

src/Handler/Admin/Ldap.hs

@@ -0,0 +1,69 @@
+-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+
+
+module Handler.Admin.Ldap
+  ( getAdminLdapR
+  , postAdminLdapR
+  ) where
+
+import Import
+-- import qualified Control.Monad.State.Class as State
+-- import Data.Aeson (encode)
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+-- import qualified Data.Set  as Set
+import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,campusUserFailoverMode,CampusUserConversionException())
+import Handler.Utils
+
+import qualified Ldap.Client as Ldap
+import Auth.LDAP
+
+
+getAdminLdapR,  postAdminLdapR :: Handler Html
+getAdminLdapR = postAdminLdapR
+postAdminLdapR = do
+  ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html -> 
+    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
+
+  let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList []))
+      procFormPerson lid = do
+        ldapPool' <- getsYesod $ view _appLdapPool
+        case ldapPool' of 
+          Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing
+          Just ldapPool -> do 
+            addMessage Info  $ text2Html "Input for LDAP test received."
+            ldapData <- campusUser'' ldapPool campusUserFailoverMode lid                      
+            decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData
+            whenIsLeft decodedErr $ addMessageI Error
+            return ldapData
+  mbLdapData <- formResultMaybe presult procFormPerson
+
+
+  ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html -> 
+    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
+  let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User)))
+      procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid)
+  mbLdapUpsert <- formResultMaybe uresult procFormUpsert
+
+
+  actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute
+  siteLayoutMsg MsgMenuLdap $ do
+    setTitleI MsgMenuLdap
+    let personForm = wrapForm pwidget def
+                      { formAction = Just $ SomeRoute actionUrl
+                      , formEncoding = penctype
+                      }
+        upsertForm = wrapForm uwidget def 
+                      { formAction = Just $ SomeRoute actionUrl
+                      , formEncoding = uenctype
+                      }
+        presentUtf8   lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
+        presentLatin1 lv = Text.intercalate ", " (                 Text.decodeLatin1 <$> lv)
+
+    -- TODO: use i18nWidgetFile instead if this is to become permanent
+    $(widgetFile "ldap")
+

src/Handler/Admin/Test.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -28,7 +28,9 @@ import Text.Hamlet
 -- import Handler.Utils.I18n
 
 import Handler.Admin.Test.Download (testDownload)
-
+import qualified Database.Esqueleto.Experimental as E (selectOne, unValue)
+import qualified Database.Esqueleto.PostgreSQL as E  (now_)
+import qualified Database.Esqueleto.Utils as E (psqlVersion_)
 
 -- BEGIN - Buttons needed only here
 data ButtonCreate = CreateMath | CreateInf | CrashApp -- Dummy for Example
@@ -112,7 +114,7 @@ postAdminTestR = do
   let emailWidget' = wrapForm emailWidget def
         { formAction = Just . SomeRoute $ AdminTestR
         , formEncoding = emailEnctype
-        , formAttrs = [("uw-async-form", "")]
+        , formAttrs = [asyncSubmitAttr] -- equivalent to [("uw-async-form", "")]
         }
 
   now <- liftIO getCurrentTime
@@ -226,6 +228,9 @@ postAdminTestR = do
 
   UniWorX{ appSettings' = AppSettings{..} } <- getYesod
 
+  psqlVersion <- runDBRead $ E.selectOne $ return E.psqlVersion_
+  dbTime      <- runDBRead $ E.selectOne $ return E.now_
+
   let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
   siteLayout locallyDefinedPageHeading $ do
   -- defaultLayout $ do
@@ -321,12 +326,23 @@ postAdminTestR = do
         <dl .deflist>
           <dt .deflist__dt>        appJobCronInterval
           <dd .deflist__dd>#{tshow appJobCronInterval}
-          <dt .deflist__dt>        appUserSyncWithin
+          <dt .deflist__dt>        appSynchroniseLdapUsersWithin
-          <dd .deflist__dd>#{tshow appUserSyncWithin}
+          <dd .deflist__dd>#{tshow appSynchroniseLdapUsersWithin}
           <dt .deflist__dt>        appSynchroniseAvsUsersWithin
           <dd .deflist__dd>#{tshow appSynchroniseAvsUsersWithin}
     |]
 
+    [whamlet|
+      <section>
+        <h2> PostgreSQL Information
+        <dl .deflist>
+          $maybe pver <- psqlVersion
+            <dt .deflist__dt>DB Version
+            <dd .deflist__dd>#{E.unValue pver}
+          $maybe ptme <- dbTime
+            <dt .deflist__dt>DB Time
+            <dd .deflist__dd>#{tshow (E.unValue ptme)}
+    |]
 
 
 
@@ -339,7 +355,7 @@ getAdminTestPdfR = do
   encRecipient :: CryptoUUIDUser <- encrypt $ usr ^. _entityKey
   now <- liftIO getCurrentTime
   let nowaday = utctDay now
-      letter  = LetterRenewQualificationF
+      letter  = LetterRenewQualification
         { lmsLogin      = LmsIdent "abcdefgh"
         , lmsPin        = "12345678"
         , qualHolderID  = usr ^. _entityKey
@@ -351,10 +367,12 @@ getAdminTestPdfR = do
         , qualShort     = qual ^. _qualificationShorthand . _CI
         , qualSchool    = qual ^. _qualificationSchool
         , qualDuration  = qual ^. _qualificationValidDuration
+        , qualRenewAuto = qual ^. _qualificationElearningRenews
+        , qualELimit    = qual ^. _qualificationElearningLimit
         , isReminder    = False
         }
   apcIdent <- letterApcIdent letter encRecipient now
-  renderLetterPDF usr letter apcIdent >>= \case
+  renderLetterPDF usr letter apcIdent Nothing >>= \case
     Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
     Right pdf -> do
       liftIO $ LBS.writeFile "/tmp/generated.pdf" pdf

src/Handler/CommCenter.hs

@@ -0,0 +1,152 @@
+-- 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
+
+
+-- avoids repetition of local definitions
+single :: (k,a) -> Map k a
+single = uncurry Map.singleton
+
+
+data CCTableAction = CCActDummy -- just a dummy, since we don't now yet which actions we will be needing
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+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 = mconcat
+      [ single ("sent"      , FilterColumn . E.mkDayFilterTo
+                                $ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used
+      , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
+                                $ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName])
+      , single ("subject"   , FilterColumn . E.mkContainsFilterWithCommaPlus Just
+                                $ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename
+                                                     ,E.str2text' $ queryMail  row E.?. SentMailHeaders  ])
+      ]
+    dbtFilterUI mPrev = mconcat
+      [ prismAForm (singletonFilter "date"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgPrintJobCreated)
+      , 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")
+

src/Handler/Course/Edit.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -46,12 +46,13 @@ data CourseForm = CourseForm
         , cfRegTo        :: Maybe UTCTime
         , cfDeRegUntil   :: Maybe UTCTime
         , cfLecturers    :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
+        , cfQualis       :: [(QualificationId, Int)]
         }
 
 makeLenses_ ''CourseForm
 
-courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> CourseForm
+courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> [CourseQualification] -> CourseForm
-courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
+courseToForm (Entity cid Course{..}) lecs lecInvites qualis = CourseForm
     { cfCourseId            = Just cid
     , cfName                = courseName
     , cfDesc                = courseDescription
@@ -69,6 +70,9 @@ courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
     , cfDeRegUntil          = courseDeregisterUntil
     , cfLecturers           = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
                            ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ]
+    -- TODO: Filterung nach aktueller Schule, da ansonsten ein Sicherheitleck droht! Siehe #150
+    , cfQualis              = [ (courseQualificationQualification, courseQualificationSortOrder)
+                              | CourseQualification{..} <- qualis, courseQualificationCourse == cid ]
     }
 
 
@@ -81,17 +85,19 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
     MsgRenderer mr <- getMsgRenderer
 
     uid <- liftHandler requireAuthId
-    (lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do
+    (userSchools, elegibleQualifications) :: ([SchoolId], OptionList QualificationId) <- liftHandler . runDB $ do
-      lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
+      lecturerSchools   <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
-      protoAdminSchools  <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
+      protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]]    [] -- default rights
-      adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
+      adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools -- and user as admin rights active right now
       oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust
-      return (lecturerSchools, adminSchools, oldSchool)
+      let elegibleSchools = Set.fromList $ lecturerSchools ++ adminSchools
-    let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
+          userSchools = Set.toList $ maybe id Set.insert oldSchool elegibleSchools
+      elegibleQualifications <- selectList [QualificationSchool <-. Set.toList elegibleSchools] [Asc QualificationName, Asc QualificationSchool]
+      return (userSchools, qualificationsOptionList elegibleQualifications)
 
     (termsField, userTerms) <- liftHandler $ case template of
       -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
-      (Just cform)  | (Just cid) <- cfCourseId cform -> do -- edit existing course
+      (Just cform)  | (Just cid) <- cfCourseId cform -> do -- edit existing course& \c
           _courseOld@Course{..} <- runDB $ get404 cid
           mayEditTerm <- isAuthorized TermEditR True
           mayDelete   <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
@@ -102,51 +108,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
               -> return (termsSetField [cfTerm cform], [cfTerm cform])
       _allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms
 
-    let miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
+    let lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
-        miAdd _ _ _ nudge btn = Just $ \csrf -> do
-          (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
-          let addRes'' = addRes <&> \newDat oldDat -> if
-                | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
-                , not $ Set.null existing
-                  -> FormFailure [mr MsgCourseLecturerAlreadyAdded]
-                | otherwise
-                  -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
-              addView' = $(widgetFile "course/lecturerMassInput/add")
-          return (addRes'', addView')
-
-        miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
-        miCell _ (Right lid) defType nudge = \csrf -> do
-          (lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType)
-          usr <- liftHandler . runDB $ get404 lid
-          let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
-          return (Just <$> lrwRes,lrwView')
-        miCell _ (Left lEmail) defType nudge = \csrf -> do
-          (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
-          invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
-          let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
-          return (lrwRes,lrwView')
-
-        miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
-                 -> ListPosition -- ^ Coordinate to delete
-                 -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
-        miDelete = miDeleteList
-
-        miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
-        miAddEmpty _ _ _ = Set.empty
-
-        miLayout :: ListLength
-                 -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
-                 -> Map ListPosition Widget -- ^ Cell widgets
-                 -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
-                 -> Map (Natural, ListPosition) Widget -- ^ Addition widgets
-                 -> Widget
-        miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
-
-        miIdent :: Text
-        miIdent = "lecturers"
-
-
-        lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
         lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
                 MassInput{..}
                 (fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical)
@@ -163,6 +125,79 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
             unliftEither (Right (lid   , lType )) = (Right lid  , Just lType)
             unliftEither (Left  (lEmail, mLType)) = (Left lEmail, mLType    )
 
+            miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
+            miAdd _ _ _ nudge btn = Just $ \csrf -> do
+              (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
+              let addRes'' = addRes <&> \newDat oldDat -> if
+                    | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
+                    , not $ Set.null existing
+                      -> FormFailure [mr MsgCourseLecturerAlreadyAdded]
+                    | otherwise
+                      -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
+                  addView' = $(widgetFile "course/lecturerMassInput/add")
+              return (addRes'', addView')
+
+            miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
+            miCell _ (Right lid) defType nudge = \csrf -> do
+              (lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType)
+              usr <- liftHandler . runDB $ get404 lid
+              let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
+              return (Just <$> lrwRes,lrwView')
+            miCell _ (Left lEmail) defType nudge = \csrf -> do
+              (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
+              invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
+              let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
+              return (lrwRes,lrwView')
+
+            miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
+                    -> ListPosition -- ^ Coordinate to delete
+                    -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
+            miDelete = miDeleteList
+
+            miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
+            miAddEmpty _ _ _ = Set.empty
+
+            miLayout :: ListLength
+                    -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
+                    -> Map ListPosition Widget -- ^ Cell widgets
+                    -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
+                    -> Map (Natural, ListPosition) Widget -- ^ Addition widgets
+                    -> Widget
+            miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
+
+            miIdent :: Text
+            miIdent = "lecturers"
+
+        qualificationsForm :: Maybe [(QualificationId, Int)] -> AForm Handler [(QualificationId, Int)] -- filter by admin school done later through upsertCourseQualifications
+        qualificationsForm = massInputAccumEditA miAdd miEdit miButtonAction miLayout miIdent (fslI $ MsgCourseQualifications 9) False
+          where
+            miIdent :: Text
+            miIdent = "qualifications"
+
+            miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([(QualificationId,Int)] -> FormResult [(QualificationId,Int)])
+            miAdd  nudge submitView csrf = do
+              (formRes, formView) <- aCourseQualiForm nudge Nothing csrf
+              let addRes = formRes <&> \newDat@(newQid,oldOrd) (unzip -> (oldQids,oldOrds)) ->
+                    let qidBad = guardMonoid (newQid `elem` oldQids) [mr MsgCourseEditQualificationFailExists]
+                        ordBad = guardMonoid (oldOrd `elem` oldOrds) [mr MsgCourseEditQualificationFailOrder ]
+                        problems = qidBad ++ ordBad
+                    in if null problems
+                        then FormSuccess $ pure newDat
+                        else FormFailure problems
+              return (addRes, $(widgetFile "widgets/massinput/courseQualifications/add"))
+
+            miEdit :: (Text -> Text) -> (QualificationId, Int) -> Form (QualificationId, Int)
+            miEdit nudge  = aCourseQualiForm nudge . Just
+
+            miLayout :: MassInputLayout ListLength (QualificationId,Int) (QualificationId, Int)
+            miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/courseQualifications/layout")
+
+            aCourseQualiForm :: (Text -> Text) -> Maybe (QualificationId, Int) -> Form (QualificationId, Int)
+            aCourseQualiForm nudge mTemplate csrf = do
+              (cquRes, cquView) <- mpreq (selectField $ pure elegibleQualifications) ("" & addName (nudge "cquali")) (view _1 <$> mTemplate)
+              (ordRes, ordView) <- mpreq     intField                                ("" & addName (nudge "cqordr")) (view _2 <$> mTemplate)
+              return ((,) <$> cquRes <*> ordRes, $(widgetFile "widgets/massinput/courseQualifications/form"))
+
     (newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of
         (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing)
         _allIOtherCases -> do
@@ -208,6 +243,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
             & setTooltip MsgCourseDeregisterUntilTip)                   (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
       <*  aformSection MsgCourseFormSectionAdministration
       <*> lecturerForm
+      <*> qualificationsForm (cfQualis <$> template)
     return (result, widget)
 
 
@@ -227,6 +263,10 @@ validateCourse = do
   unless userAdmin $ do
     guardValidation MsgCourseUserMustBeLecturer
       $ anyOf (traverse . _Right . _1) (== uid) cfLecturers
+  guardValidation MsgCourseEditQualificationFailExists
+    $ not $ hasDuplicates $ fst <$> cfQualis
+  guardValidation MsgCourseEditQualificationFailOrder
+    $ not $ hasDuplicates $ snd <$> cfQualis
 
   warnValidation MsgCourseShorthandTooLong
     $ length (CI.original cfShort) <= 10
@@ -280,8 +320,11 @@ getCourseNewR = do
           E.limit 1
           return course
       template <- case oldCourses of
-        (oldTemplate:_) ->
+        (oldTemplate:_) -> runDB $ do
-            let newTemplate = courseToForm oldTemplate mempty mempty in
+            mbLecs       <- oldTemplate & \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
+            mbLecInvites <- oldTemplate & sourceInvitationsF . entityKey
+            mbQualis     <- oldTemplate & \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder]
+            let newTemplate = courseToForm oldTemplate mbLecs mbLecInvites mbQualis
             return $ Just $ newTemplate
                 { cfCourseId   = Nothing
                 , cfTerm       = TermKey $ termFromRational 0 -- invalid, will be ignored; undefined won't work due to strictness
@@ -291,9 +334,9 @@ getCourseNewR = do
                 }
         [] -> do
             (tidOk,sshOk,cshOk) <- runDB $ (,,)
-                <$> ifMaybeM mbTid True existsKey
+                <$> ifNothingM mbTid True existsKey
-                <*> ifMaybeM mbSsh True existsKey
+                <*> ifNothingM mbSsh True existsKey
-                <*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
+                <*> ifNothingM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
             unless tidOk $ addMessageI Warning $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
             unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
             unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
@@ -314,10 +357,11 @@ pgCEditR tid ssh csh = do
       mbCourse     <- getBy (TermSchoolCourseShort tid ssh csh)
       mbLecs       <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
       mbLecInvites <- for mbCourse $ sourceInvitationsF . entityKey
-      return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
+      mbQualis     <- for mbCourse $ \course -> map entityVal <$> selectList [CourseQualificationCourse ==. entityKey course] [Asc CourseQualificationSortOrder]
+      return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbQualis
   -- IMPORTANT: both GET and POST Handler must use the same template,
   --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
-  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
+  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 4) courseToForm <$> courseData
 
 
 -- | Course Creation and Editing
@@ -357,6 +401,7 @@ courseEditHandler miButtonAction mbCourseForm = do
               let (invites, adds) = partitionEithers $ cfLecturers res
               insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
               sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
+              void $ upsertCourseQualifications aid cid $ cfQualis res
               insert_ $ CourseEdit aid now cid
               memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
             return insertOkay
@@ -405,11 +450,9 @@ courseEditHandler miButtonAction mbCourseForm = do
                     let (invites, adds) = partitionEithers $ cfLecturers res
                     insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
                     sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
-
+                    void $ upsertCourseQualifications aid cid $ cfQualis res
                     insert_ $ CourseEdit aid now cid
-
                     memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
-
                     addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True
           when success $ redirect $ CourseR tid ssh csh CShowR
@@ -420,3 +463,35 @@ courseEditHandler miButtonAction mbCourseForm = do
         { formAction = Just $ SomeRoute actionUrl
         , formEncoding = formEnctype
         }
+
+-- upsertCourseQualifications :: forall m backend . (MonadIO m, PersistStoreWrite backend, PersistQueryRead backend) => UserId -> CourseId -> [(QualificationId, Int)] -> ReaderT backend m Bool
+upsertCourseQualifications :: UserId -> CourseId -> [(QualificationId, Int)] -> YesodJobDB UniWorX Bool -- could be generalized
+upsertCourseQualifications uid cid qualis = do
+  let newQualis = Map.fromList qualis
+  oldQualis <- Map.fromList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder)))
+                <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationQualification]
+  -- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications, see #150
+  okSchools <- Set.fromList . fmap (userFunctionSchool . entityVal)
+                <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool]
+  {- Some debugging due to an error caused by using fromDistinctAscList with violated precondition:
+  $logErrorS "CourseQuali" $ "OLD  Course Qualifications:" <> tshow oldQualis
+  $logErrorS "CourseQuali" $ "NEW  Course Qualifications:" <> tshow newQualis
+  $logErrorS "CourseQuali" $ "DIFF Course Qualifications:" <> tshow (newQualis Map.\\ oldQualis)
+  -}
+  foldWithKeyMapM oldQualis $ \qu (k, so_old) -> case Map.lookup qu newQualis of
+        Just so_new | so_new /= so_old
+                -> update k [CourseQualificationSortOrder =. so_new] -- existing CourseQualifications may be re-ordered, regardless of school association
+        Nothing -> delete k                                          -- existing CourseQualifications may be removed,    regardless of school association
+        _       -> return ()
+  res <- foldWithKeyMapM (newQualis Map.\\ oldQualis) $ \qu so -> get qu >>= \case
+        Just Qualification{qualificationSchool=ssh, qualificationShorthand=qsh}
+          | Set.member ssh okSchools ->
+              insert_ CourseQualification{courseQualificationQualification = qu, courseQualificationCourse = cid, courseQualificationSortOrder = so}
+              $> All True
+          | otherwise -> do
+              addMessageI Warning $ MsgCourseEditQualificationFailRights qsh ssh
+              pure $ All False
+        _ -> do
+              addMessageI Warning   MsgCourseEditQualificationFail
+              pure $ All False
+  pure $ getAll res

src/Handler/Course/Register.hs

@@ -68,7 +68,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
       | otherwise
         -> return $ FormSuccess ()
 
-    mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> do
+    mayViewCourseAfterDeregistration <- liftHandler . runDBRead $ E.selectExists . E.from $ \course -> do
       E.where_ $  course E.^. CourseId E.==. E.val cid
            E.&&. (       isSchoolAdminLike muid ata (course E.^. CourseSchool)
                    E.||. mayEditCourse muid ata course

src/Handler/Course/User.hs

@@ -9,12 +9,11 @@ module Handler.Course.User
 import Import
 
 import Utils.Form
+import Utils.Mail (pickValidUserEmail)
 import Handler.Utils
 import Handler.Utils.SheetType
-import Handler.Utils.Profile (pickValidEmail)
 import Handler.Utils.StudyFeatures
 import Handler.Submission.List
-
 import Handler.Course.Register
 
 import Jobs.Queue

src/Handler/Course/Users.hs

@@ -129,7 +129,7 @@ _userSheets = _dbrOutput . _7
 
 -- _userQualifications :: Traversal' UserTableData [Entity Qualification]
 -- _userQualifications = _dbrOutput . _8 . (traverse _1)
--- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualfications -> f UserTableQualifications
+-- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualifications -> f UserTableQualifications
 
 _userQualifications :: Getter UserTableData [Entity Qualification]
 _userQualifications = _dbrOutput . _8 . to (fmap fst3)
@@ -204,6 +204,7 @@ data UserTableCsv = UserTableCsv
   , csvUserSex :: Maybe Sex
   , csvUserBirthday :: Maybe Day
   , csvUserMatriculation :: Maybe UserMatriculation
+  , csvUserEPPN :: Maybe UserEduPersonPrincipalName
   , csvUserEmail :: UserEmail
   , csvUserQualifications :: [QualificationName]
   , csvUserSubmissionGroup :: Maybe SubmissionGroupName
@@ -223,6 +224,7 @@ instance Csv.ToNamedRecord UserTableCsv where
     , "sex" Csv..= csvUserSex
     , "birthday" Csv..= csvUserBirthday
     , "matriculation" Csv..= csvUserMatriculation
+    , "eduPersonPrincipalName" Csv..= csvUserEPPN
     , "email" Csv..= csvUserEmail
     , "qualifications" Csv..= CsvSemicolonList csvUserQualifications
     , "submission-group" Csv..= csvUserSubmissionGroup
@@ -284,6 +286,7 @@ data UserTableJson = UserTableJson
   , jsonUserName :: UserDisplayName
   , jsonUserSex :: Maybe (Maybe Sex)
   , jsonUserMatriculation :: Maybe UserMatriculation
+  , jsonUserEPPN :: Maybe UserEduPersonPrincipalName
   , jsonUserEmail :: UserEmail
   , jsonUserQualifications :: Set QualificationName
   , jsonUserSubmissionGroup :: Maybe SubmissionGroupName
@@ -320,6 +323,7 @@ instance ToJSON UserTableJson where
     , pure $ "name" JSON..= jsonUserName
     , ("sex" JSON..=) <$> jsonUserSex
     , ("matriculation" JSON..=) <$> jsonUserMatriculation
+    , ("eduPersonPrincipalName" JSON..=) <$> jsonUserEPPN
     , pure $ "email" JSON..= jsonUserEmail
     , ("qualifications" JSON..=) <$> assertM' (not . onull) jsonUserQualifications
     , ("submission-group" JSON..=) <$> jsonUserSubmissionGroup
@@ -562,6 +566,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
                   <*> view (hasUser . _userSex)
                   <*> view (hasUser . _userBirthday)
                   <*> view (hasUser . _userMatrikelnummer)
+                  <*> view (hasUser . _userLdapPrimaryKey)
                   <*> view (hasUser . _userEmail)
                   <*> (over traverse (qualificationName . entityVal) <$> view _userQualifications)
                   <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
@@ -593,6 +598,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
               <*> view  (hasUser . _userDisplayName)
               <*> views (hasUser . _userSex) (guardOn showSex)
               <*> view  (hasUser . _userMatrikelnummer)
+              <*> view  (hasUser . _userLdapPrimaryKey)
               <*> view  (hasUser . _userEmail)
               <*> view (_userQualifications . folded . to (Set.singleton . qualificationName . entityVal))
               <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)

src/Handler/Exam/Users.hs

@@ -187,6 +187,7 @@ data ExamUserTableCsv = ExamUserTableCsv
   , csvEUserFirstName :: Maybe Text
   , csvEUserName :: Maybe Text
   , csvEUserMatriculation :: Maybe Text
+  , csvEUserEPPN :: Maybe UserEduPersonPrincipalName
   , csvEUserStudyFeatures :: UserTableStudyFeatures
   , csvEUserOccurrence :: Maybe (CI Text)
   , csvEUserExercisePoints :: Maybe (Maybe Points)
@@ -207,6 +208,7 @@ instance ToNamedRecord ExamUserTableCsv where
     , "first-name" Csv..= csvEUserFirstName
     , "name" Csv..= csvEUserName
     , "matriculation" Csv..= csvEUserMatriculation
+    , "eduPersonPrincipalName" Csv..= csvEUserEPPN
     , "study-features" Csv..= csvEUserStudyFeatures
     , "occurrence" Csv..= csvEUserOccurrence
     ] ++ catMaybes
@@ -232,6 +234,7 @@ instance FromNamedRecord ExamUserTableCsv where
       <*> csv .:?? "first-name"
       <*> csv .:?? "name"
       <*> csv .:?? "matriculation"
+      <*> csv .:?? "eduPersonPrincipalName"
       <*> pure mempty
       <*> csv .:?? "occurrence"
       <*> fmap Just (csv .:?? "exercise-points")
@@ -274,7 +277,7 @@ examUserTableCsvHeader :: ( MonoFoldable mono
                        => SheetGradeSummary -> Bool -> mono -> Csv.Header
 examUserTableCsvHeader allBoni doBonus pNames = Csv.header $
   [ "surname", "first-name", "name"
-  , "matriculation"
+  , "matriculation", "eduPersonPrincipalName"
   , "study-features"
   , "course-note"
   , "occurrence"
@@ -612,6 +615,7 @@ postEUsersR tid ssh csh examn = do
                 <*> view (resultUser . _entityVal . _userFirstName . to Just)
                 <*> view (resultUser . _entityVal . _userDisplayName . to Just)
                 <*> view (resultUser . _entityVal . _userMatrikelnummer)
+                <*> view (resultUser . _entityVal . _userLdapPrimaryKey)
                 <*> view resultStudyFeatures
                 <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
                 <*> fmap (bool (const Nothing) Just showPoints) (preview $ resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped)
@@ -935,6 +939,7 @@ postEUsersR tid ssh csh examn = do
               guessUser' ExamUserTableCsv{..} = do
                 let criteria = PredDNF . maybe Set.empty Set.singleton . fromNullable . Set.fromList . fmap PLVariable $ catMaybes
                       [ GuessUserMatrikelnummer <$> csvEUserMatriculation
+                      , GuessUserEduPersonPrincipalName <$> csvEUserEPPN
                       , GuessUserDisplayName <$> csvEUserName
                       , GuessUserSurname <$> csvEUserSurname
                       , GuessUserFirstName <$> csvEUserFirstName

src/Handler/Firm.hs

@@ -19,6 +19,7 @@ import Import
 
 -- import Jobs
 import Handler.Utils
+import Handler.Utils.Company
 import Handler.Utils.Communication
 import Handler.Utils.Avs (guessAvsUser)
 
@@ -28,11 +29,12 @@ import qualified Data.Map as Map
 -- 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.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)
+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.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
@@ -55,7 +57,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU
 
 data FirmAction = FirmActNotify
                 | FirmActResetSupervision
-                | FirmActAddSupersvisors
+                | FirmActAddSupervisors
                 | FirmActChangeContactFirm
                 | FirmActChangeContactUser
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
@@ -69,10 +71,11 @@ data FirmActionData = FirmActNotifyData
                         { firmActResetKeepOldSupers       :: Maybe Bool
                         , firmActResetMutualSupervision   :: Maybe Bool
                         }
-                    | FirmActAddSupersvisorsData
+                    | FirmActAddSupervisorsData
                         { firmActAddSupervisorIds         :: Set Text
                         , firmActAddSupervisorReroute     :: Bool
                         , firmActAddSupervisorPostal      :: Maybe Bool
+                        , firmActAddSupervisorReason      :: Maybe Text
                         }
                     | FirmActChangeContactFirmData
                         { firmActCCFPostalAddr            :: Maybe StoredMarkup
@@ -81,6 +84,7 @@ data FirmActionData = FirmActNotifyData
                         }
                     | FirmActChangeContactUserData
                         { firmActCCUPostalAddr            :: Maybe StoredMarkup
+                        , firmActCCUUseCompanyPostal      :: Maybe Bool
                         , firmActCCUPostalPref            :: Maybe Bool
                         }
   deriving (Eq, Ord, Read, Show, Generic)
@@ -90,21 +94,31 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
   where
     mkAct True  FirmActNotify           = singletonMap FirmActNotify           $ pure FirmActNotifyData
     mkAct _     FirmActResetSupervision = singletonMap FirmActResetSupervision $      FirmActResetSupervisionData
-                  <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                     (Just $ Just False)
+                  <$> aopt boolField'                       (fslI MsgFirmActResetSuperKeep)                     (Just $ Just False)
-                  <*> aopt checkBoxField                                      (fslI MsgFirmActResetMutualSupervision)             (Just $ Just True )
+                  <*> aopt checkBoxField                    (fslI MsgFirmActResetMutualSupervision)             (Just $ Just True )
-    mkAct _     FirmActAddSupersvisors   = singletonMap FirmActAddSupersvisors   $ FirmActAddSupersvisorsData
+    mkAct _     FirmActAddSupervisors   = singletonMap FirmActAddSupervisors   $ FirmActAddSupervisorsData
-                  <$> areq (textField & cfAnySeparatedSet)  (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
+                  <$> areq (textField & cfAnySeparatedSet)  (fslI MsgFirmSuperDefault & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
                   <*> areq checkBoxField                    (fslI MsgTableIsDefaultReroute)                                                             (Just True)
                   <*> aopt postalEmailField                 (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip)                                Nothing
+                  <*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons)
+                                                            (fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip)                        Nothing
     mkAct _     FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
                   <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
                   <*> aopt (emailField & cfStrip & cfCI)    (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing
-                  <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip)   Nothing
+                  <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFirmDefaultPreferenceInfo)   Nothing
                   <*  aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
     mkAct _     FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
                   <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
+                  <*> aopt boolField'                       (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
                   <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
     mkAct _  _ = mempty
+    ucdefSuperReasons :: HandlerFor UniWorX (OptionList Text)
+    ucdefSuperReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
+      fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
+        usrc <- E.from $ E.table @UserCompany
+        E.where_ $ E.isJust $ usrc E.^. UserCompanyReason
+        return $ usrc E.^. UserCompanyReason
+
 
 firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData
 firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing
@@ -118,7 +132,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
     faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
 
     faHandler (FirmActNotifyData, Set.toList -> fids) = do
-      usrs <- runDB $ E.select $ E.distinct $ do
+      usrs <- runDBRead $ E.select $ E.distinct $ do
         (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
         E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids
         return $ usr E.^. UserId
@@ -135,17 +149,19 @@ firmActionHandler route isAdmin = flip formResult faHandler
         delSupers <- if firmActResetKeepOldSupers == Just False
           then E.deleteCount $ do
                 spr <- E.from $ E.table @UserSupervisor
-                E.where_ $ suprFltr spr E.&&. E.exists (do
+                E.where_ $ suprFltr spr
-                    usr <- E.from $ E.table @UserCompany
+                    E.&&. spr E.^. UserSupervisorReason E.~=. E.val (tshow SupervisorReasonCompanyDefault)
-                    E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
+                    E.&&. E.exists (do
-                        E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
+                      usr <- E.from $ E.table @UserCompany
-                  )
+                      E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
+                          E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
+                    )
           else return 0
-        newSupers <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids
+        newSupers <- addDefaultSupervisorsFor (Just $ tshow SupervisorReasonCompanyDefault) madId (firmActResetMutualSupervision /= Just False) fids
         addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
       reloadKeepGetParams route -- reload to reflect changes
 
-    faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do
+    faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do
       avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
       let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
           usersFound = mapMaybe snd usersFound'
@@ -161,7 +177,9 @@ firmActionHandler route isAdmin = flip formResult faHandler
         addMessageI Warning MsgFirmActAddSupersEmpty
         reloadKeepGetParams route
       runDB $ do
-        putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound]
+        -- putMany [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] -- putMany always overwrites existing records, which would destroy priority and useCompanyAddress here
+        -- upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [copyField UserCompanySupervisor, copyField UserCompanySupervisorReroute] [] [] -- overwrite Supervisor and SupervisorReroute, keep priority and useCompanyAddress
+        upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False firmActAddSupervisorReason| uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute, UserCompanyReason =. firmActAddSupervisorReason] [] -- identical to previous line, but perhaps more clear?
         whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
           updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
         addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal
@@ -174,25 +192,34 @@ firmActionHandler route isAdmin = flip formResult faHandler
             , (CompanyPrefersPostal =.)        <$>           firmActCCFPostalPref
             ]
       in unless (null changes) $ do
-        runDB $ updateBy (UniqueCompanyShorthand $ unCompanyKey cid) changes
+        runDB $ update cid changes
         addMessageI Success MsgFirmActChangeContactFirmResult
         reloadKeepGetParams route
 
-    faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) =
+    faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid])
-      let changes = catMaybes
+      | firmActCCUUseCompanyPostal == Just True, isJust firmActCCUPostalAddr =
-            [ (UserPostAddress   E.=.) . E.justVal <$> canonical firmActCCUPostalAddr  -- note that Nothing means no change and not delete address!
+          addMessageI Error MsgCompanyUserUseCompanyPostalError
-            , (UserPrefersPostal E.=.) . E.val     <$>           firmActCCUPostalPref
+      | otherwise = do
-            ]
+          let changes = catMaybes
-      in unless (null changes) $ do
+                [ toMaybe (firmActCCUUseCompanyPostal == Just True) (UserPostAddress   E.=. E.nothing)      -- precondition ensures that only one update applies for UserPostAddress
-        nrChanged <- runDB $ E.updateCount $ \usr -> do
+                , (UserPostAddress   E.=.) . E.justVal <$> canonical firmActCCUPostalAddr  -- note that Nothing means no change and not delete address!
-          E.set usr changes
+                , (UserPrefersPostal E.=.) . E.val     <$>           firmActCCUPostalPref
-          E.where_ $ E.exists $ do
+                ]
-            usrCmpy <- E.from $ E.table @UserCompany
+          (total, nrChanged) <- runDB $ do
-            E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
+            nrUsrChange <- E.updateCount $ \usr -> do
-                E.&&.  usrCmpy E.^. UserCompanyUser    E.==. usr E.^. UserId
+              E.set usr changes
-        addMessageI Success $ MsgFirmUserChanges nrChanged
+              E.where_ $ E.exists $ do
-        reloadKeepGetParams route  -- reload to reflect changes
+                usrCmpy <- E.from $ E.table @UserCompany
-
+                E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
+                    E.&&.  usrCmpy E.^. UserCompanyUser    E.==. usr E.^. UserId
+            nrUseComp <- case firmActCCUUseCompanyPostal of
+              Just x  -> updateWhereCount [UserCompanyCompany ==. cid] [UserCompanyUseCompanyAddress =. x]
+              Nothing -> return 0
+            nrCid <- count [UserCompanyCompany ==. cid]
+            return (fromIntegral nrCid, max nrUsrChange nrUseComp)
+          let allok = bool Warning Success $ nrChanged == total
+          addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
+          reloadKeepGetParams route  -- reload to reflect changes
     faHandler _ = addMessageI Error MsgErrorUnknownFormAction
 
 
@@ -227,89 +254,35 @@ runFirmActionFormPost cid route isAdmin acts = do
 -- Firm specific utilities
 -- for filters and counts also see before FirmAllR Handlers
 
-
-
--- remove supervisors:
-deleteSupervisors :: NonEmpty UserId -> DB Int64
-deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs]
-
--- reset supervisors given employees of a company to default company supervision, deleting all other supervisors
-resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
-resetSupervisors cid employees = do
-  nr_del <- deleteSupervisors employees
-  nr_add <- addDefaultSupervisors cid employees
-  return $ max nr_del nr_add
-
--- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
-addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
-addDefaultSupervisors 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)
-    )
-    (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications])
-
--- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
-addDefaultSupervisorsFor ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64
-addDefaultSupervisorsFor 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)
-    )
-    (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] )
-
--- like `addDefaultSupervisors`, but selects all employees of given companies from database
-addDefaultSupervisorsAll ::  (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
-addDefaultSupervisorsAll 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)
-    )
-    (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] )
-
-
-------------------------------
 -- repeatedly useful queries
 
+usrPrimaryCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
+-- usrPrimaryCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative
+usrPrimaryCompanies cmp usr = do
+  othr <- E.from $ E.table @UserCompany
+  E.where_ $ othr E.^. UserCompanyPriority E.>.  usr E.^. UserCompanyPriority
+      E.&&.  othr E.^. UserCompanyUser     E.==. usr E.^. UserCompanyUser
+      E.&&.  othr E.^. UserCompanyCompany  E.!=. cmp E.^. CompanyId                     -- redundant due to > above, but likely performance improving
+  -- return othr
+
 fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
 fromUserCompany mbFltr cmpy = do
   usrCmpy <- E.from $ E.table @UserCompany
   let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
   E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr
 
-firmCountUsers        :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountUsers              :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-firmCountUsers        = E.subSelectCount . fromUserCompany Nothing
+firmCountUsers              = E.subSelectCount . fromUserCompany Nothing
+
+firmCountUsersPrimary       :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountUsersPrimary cmp   = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
+  where
+    primFltr = E.notExists . usrPrimaryCompanies cmp
+
+firmCountUsersSecondary     :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountUsersSecondary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
+  where
+    primFltr =    E.exists . usrPrimaryCompanies cmp
 
 firmCountSupervisors  :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
 firmCountSupervisors  = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
@@ -422,7 +395,7 @@ type AllCompanyTableExpr = E.SqlExpr (Entity Company)
 queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
 queryAllCompany = id
 
-type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Bool, E.Value Bool)
+type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Bool, E.Value Bool, E.Value Word64)
 resultAllCompanyEntity          :: Lens' AllCompanyTableData (Entity Company)
 resultAllCompanyEntity          = _dbrOutput . _1
 
@@ -438,10 +411,12 @@ resultAllCompanySupervisors       = _dbrOutput . _3 . _unValue
 resultAllCompanyDefaultReroutes   :: Lens' AllCompanyTableData Bool
 resultAllCompanyDefaultReroutes   = _dbrOutput . _4 . _unValue
 
+resultAllCompanyUsersSecondary    :: Lens' AllCompanyTableData Word64
+resultAllCompanyUsersSecondary    = _dbrOutput . _5 . _unValue
 
 mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget)
 mkFirmAllTable isAdmin uid = do
-  -- now <- liftIO getCurrentTime
+  now <- liftIO getCurrentTime
   mr <- getMessageRender
   let
     resultDBTable = DBTable{..}
@@ -460,12 +435,13 @@ mkFirmAllTable isAdmin uid = do
                   , cmpy & firmCountUsers                       --  2
                   , cmpy & firmHasSupervisors                   --  3
                   , cmpy & firmHasDefaultReroutes               --  4
-                  -- , cmpy & firmCountEmployeeSupervised          --  4
+                  , cmpy & firmCountUsersSecondary              --  5
-                  -- , cmpy & firmCountEmployeeRerouted            --  5
+                  -- , cmpy & firmCountEmployeeSupervised
-                  -- , cmpy & firmCountEmployeeRerPost             --  6
+                  -- , cmpy & firmCountEmployeeRerouted
-                  -- , cmpy & firmCountForeignSupervisors          --  7
+                  -- , cmpy & firmCountEmployeeRerPost
-                  -- , cmpy & firmCountActiveReroutes              --  9
+                  -- , cmpy & firmCountForeignSupervisors
-                  -- , cmpy & firmCountActiveReroutes'             -- 10
+                  -- , cmpy & firmCountActiveReroutes
+                  -- , cmpy & firmCountActiveReroutes'
                   )
         dbtRowKey = (E.^. CompanyId)
         dbtProj = dbtProjFilteredPostId
@@ -478,6 +454,7 @@ mkFirmAllTable isAdmin uid = do
               in  anchorCell (FirmSupersR fsh) $ toWgt fsh
           , sortable (Just "avsnr")         (i18nCell MsgTableCompanyNo)               $ \(view resultAllCompany -> firm) -> numCell $ companyAvsId firm
           , sortable (Just "users")         (i18nCell MsgTableCompanyNrUsers)          $ \(view resultAllCompanyUsers               -> nr) -> wgtCell $ word2widget nr
+          , sortable (Just "secondary")     (i18nCell MsgTableCompanyNrSecondaryUsers) $ \(view resultAllCompanyUsersSecondary      -> nr) -> wgtCell $ word2widget nr
           , sortable (Just "supervisors")   (i18nCell MsgTableCompanyNrSupersDefault)  $ \row ->
               anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors
           , sortable (Just "reroute-def")   (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes     -> ok) -> tickmarkCell ok
@@ -495,6 +472,7 @@ mkFirmAllTable isAdmin uid = do
           , singletonMap "avsnr"          $ SortColumn (E.^. CompanyAvsId)
           , singletonMap "postal-pref"    $ SortColumn (E.^. CompanyPrefersPostal)
           , singletonMap "users"          $ SortColumn firmCountUsers
+          , singletonMap "secondary"      $ SortColumn firmCountUsersSecondary
           , singletonMap "supervisors"    $ SortColumn firmHasSupervisors
           -- , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised
           -- , singletonMap "emp-rerouted"   $ SortColumn firmCountEmployeeRerouted
@@ -599,7 +577,7 @@ mkFirmAllTable isAdmin uid = do
               case criterion of
                 Nothing -> return True :: DB Bool
                 (Just (crit::Text)) -> do
-                  critFirms <- memcachedBy (Just . Right $ 5 * diffMinute) ("svr:"<>crit) $ fmap (Set.fromAscList . fmap E.unValue) $ E.select $ E.distinct $ do
+                  critFirms <- memcachedBy (Just . Right $ 3 * diffMinute) ("SVR:"<>crit) $ fmap (Set.fromList . fmap E.unValue) $ E.select $ E.distinct $ do
                     (usr :& cmp) <- E.from  $ E.table @User `E.innerJoin` E.table @Company
                       `E.on` (\(usr :& cmp) -> E.exists (do
                         usrCmp <- E.from $ E.table @UserCompany
@@ -612,13 +590,13 @@ mkFirmAllTable isAdmin uid = do
                           E.&&. E.exists (do
                             usrSub <- E.from $ E.table @UserCompany
                             E.where_ $ usrSub E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorUser
-                                E.&&.  usrSub E.^. UserCompanyCompany E.==. cmp E.^. CompanyId
+                                E.&&.  usrSub E.^. UserCompanyCompany E.==. cmp    E.^. CompanyId
                           )
                       ))
-                    E.where_ $ (usr E.^. UserDisplayName  `E.hasInfix` E.val crit)
+                    E.where_ $ (usr E.^. UserDisplayName  `E.hasInfix` E.val        crit )
                         E.||.  (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit))
-                        E.||.  (usr E.^. UserSurname      `E.hasInfix` E.val crit)
+                        E.||.  (usr E.^. UserSurname      `E.hasInfix` E.val        crit )
-                    E.orderBy [E.asc $ cmp E.^. CompanyId]
+                    -- E.orderBy [E.asc $ cmp E.^. CompanyId]
                     return $ cmp E.^. CompanyId
                   let cid = dbr ^. resultAllCompanyEntity . _entityKey
                   return $ Set.member cid critFirms
@@ -678,6 +656,18 @@ mkFirmAllTable isAdmin uid = do
                 Just False -> E.notExists checkSuper
             )
           , single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress)))
+          , single ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do
+              (usrCmp :& usrQual :& qual) <- E.from $ E.table @UserCompany
+                `E.innerJoin` E.table @QualificationUser
+                `E.on` (\(usrCmp :& usrQual) -> usrCmp E.^. UserCompanyUser E.==. usrQual E.^. QualificationUserUser)
+                `E.innerJoin` E.table @Qualification
+                `E.on` (\(_ :& usrQual :& qual) -> qual E.^. QualificationId E.==. usrQual E.^. QualificationUserQualification)
+              E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
+                E.&&. qual E.^. QualificationShorthand E.==. E.val criterion
+                E.&&. validQualification now usrQual
+            )
+          , single ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress))
+            )
           ]
         dbtFilterUI mPrev = mconcat
           [ fltrCompanyNameUI mPrev
@@ -687,7 +677,9 @@ mkFirmAllTable isAdmin uid = do
           , prismAForm (singletonFilter "is-supervisor")                              mPrev $ aopt textField (fslI MsgTableSupervisor)
           , prismAForm (singletonFilter "is-default-supervisor")                      mPrev $ aopt textField (fslI MsgFirmSuperDefault)
           , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor)
-          , prismAForm (singletonFilter "company-postal"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern)
+          , prismAForm (singletonFilter "company-postal"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern & setTooltip MsgFilterFirmExternTooltip)
+          , prismAForm (singletonFilter "company-address")                            mPrev $ aopt textField (fslI MsgFirmAddress)
+          , fltrQualificationHdrUI MsgFilterHasQualification mPrev
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
         dbtParams = DBParamsForm
@@ -739,7 +731,9 @@ data FirmUserAction = FirmUserActNotify
                     | FirmUserActResetSupervision
                     | FirmUserActSetSupervisor
                     | FirmUserActMkSuper
+                    | FirmUserActChangeDetails
                     | FirmUserActChangeContact
+                    | FirmUserActRemove
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -748,20 +742,28 @@ embedRenderMessage ''UniWorX ''FirmUserAction id
 
 data FirmUserActionData = FirmUserActNotifyData
                         | FirmUserActResetSupervisionData
-                            { firmUserActResetKeepOldSupers     :: Maybe Bool
+                            { firmUserActResetSupers            :: Maybe Bool
-                            -- , firmUserActResetMutualSupervision :: Maybe Bool
                             }
                         | FirmUserActSetSupervisorData
-                            {  firmUserActSetSuperNames   :: Maybe (Set Text)
+                            { firmUserActSetSuperNames          :: Maybe (Set Text)
-                            ,  firmUserActSetSuperIds     :: Maybe [UserId]
+                            , firmUserActSetSuperIds            :: Maybe [UserId]
-                            ,  firmUserActSetSuperReroute :: Bool
+                            , firmUserActSetSuperReason         :: Maybe Text
-                            ,  firmUserActSetSuperKeep    :: Bool
+                            , firmUserActSetSuperReroute        :: Bool
+                            , firmUserActResetSupers            :: Maybe Bool
                             }
                         | FirmUserActMkSuperData
-                            { firmUserActMkSuperReroute   :: Maybe Bool }
+                            { firmUserActMkSuperReroute         :: Maybe Bool }
+                        | FirmUserActChangeDetailsData
+                            { firmUserActDetailPriority         :: Maybe Int
+                            , firmUserActDetailReason           :: Maybe Text
+                            }
                         | FirmUserActChangeContactData
-                            { firmUserActPostalAddr :: Maybe StoredMarkup
+                            { firmUserActPostalAddr             :: Maybe StoredMarkup
-                            , firmUserActPostalPref :: Maybe Bool
+                            , firmUserActUseCompanyPostal       :: Maybe Bool
+                            , firmUserActPostalPref             :: Maybe Bool
+                            }
+                        | FirmUserActRemoveData
+                            { firmUserActRemoveSupers           :: Bool
                             }
   deriving (Eq, Ord, Show, Generic)
 
@@ -773,7 +775,7 @@ queryUserUser = $(sqlIJproj 2 1)
 queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany)
 queryUserUserCompany = $(sqlIJproj 2 2)
 
-type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64)
+type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64, E.Value Bool)
 
 resultUserUser :: Lens' UserCompanyTableData (Entity User)
 resultUserUser = _dbrOutput . _1
@@ -787,6 +789,9 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue
 resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64
 resultUserCompanyReroutes = _dbrOutput . _4 . _unValue
 
+resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool
+resultUserCompanyPrimary = _dbrOutput . _5 . _unValue
+
 instance HasEntity UserCompanyTableData User where
   hasEntity = resultUserUser
 
@@ -798,37 +803,44 @@ mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set
 mkFirmUserTable isAdmin cid = do
   mr <- getMessageRender
   let
-    mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do
+    reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
+    mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr, E.Value mbmbReason) = do
       uuid <- toPathPiece <$> encryptUser uid
-      return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr)
+      return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr, mbmbReason == Just reasonSuperior)
 
     procOptions rawSupers = do
       procSupers <- traverse mkSprOption rawSupers
       return $ mkOptionListGrouped $ filter (notNull . snd)
-             [ (mr MsgFirmSuperDefault  , [opt | (opt, Just True ) <- procSupers])
+             [ (mr MsgTableSuperior     , [opt | (opt, _         , True ) <- procSupers])
-             , (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers])
+             , (mr MsgFirmSuperDefault  , [opt | (opt, Just True , False) <- procSupers])
-             , (mr MsgFirmSuperForeign  , [opt | (opt, Nothing   ) <- procSupers])
+             , (mr MsgFirmSuperIrregular, [opt | (opt, Just False, False) <- procSupers])
+             , (mr MsgFirmSuperForeign  , [opt | (opt, Nothing   , False) <- procSupers])
              ]
 
   rawSupers <- E.select $ do
     (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany
             `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid)
     E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
+        E.||.  (usrCmp E.?. UserCompanyReason E.?=. E.val reasonSuperior)
         E.||.  E.exists (firmQuerySupervisedBy cid Nothing usr)
-    return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor)
+    return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor, usrCmp E.?. UserCompanyReason)
   let
     -- supervisorField :: Field Handler UserId
     -- supervisorField  =      selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
     supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
 
-
     fsh = unCompanyKey cid
     resultDBTable = DBTable{..}
       where
         dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do
           EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
           E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid
-          return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp)
+          let isPrimary = E.notExists (do
+                  other <- E.from $ E.table @UserCompany
+                  E.where_ $ other E.^. UserCompanyUser     E.==. usrCmp E.^. UserCompanyUser
+                      E.&&.  other E.^. UserCompanyPriority E.>.  usrCmp E.^. UserCompanyPriority
+                  )
+          return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp, isPrimary)
         dbtRowKey = queryUserUser >>> (E.^. UserId)
         dbtProj = dbtProjId
         dbtColonnade = formColonnade $ mconcat
@@ -839,7 +851,16 @@ mkFirmUserTable isAdmin cid = do
           , sortable (Just "supervisors")     (i18nCell MsgTableCompanyNrSupers       )  $ \(view resultUserCompanySupervisors  -> nr) -> wgtCell $ word2widget nr
           , sortable (Just "reroutes")        (i18nCell MsgTableCompanyNrRerouteActive)  $ \(view resultUserCompanyReroutes     -> nr) -> wgtCell $ word2widget nr
           , sortable (Just "postal-pref")     (i18nCell MsgPrefersPostal)                $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
+          , sortable Nothing                  (i18nCell MsgCompanyUserUseCompanyAddress) $ \row ->
+              let noUsrAddr = isNothing $ row ^. resultUserUser . _userPostAddress
+                  useCompA  = row ^. resultUserUserCompany . _entityVal . _userCompanyUseCompanyAddress
+              in tickmarkCell $ noUsrAddr && useCompA
           , colUserEmail
+          , sortable (Just "usr-reason")      (i18nCell MsgTableCompanyReason)           $ \(view $ resultUserUserCompany . _entityVal . _userCompanyReason -> r) -> cellMaybe textCell r
+          , sortable (Just "priority")        (i18nCell MsgCompanyUserPriority)          $ \row ->
+              let prio :: Int = row ^. resultUserUserCompany . _entityVal . _userCompanyPriority
+                  isPrime     = row ^. resultUserCompanyPrimary
+              in numCell prio <> spacerCell <> ifIconCell isPrime IconTop
           , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
           ]
         dbtSorting = mconcat
@@ -850,6 +871,8 @@ mkFirmUserTable isAdmin cid = do
           , singletonMap "personal-number"  $ SortColumn $ queryUserUser        >>> (E.^. UserCompanyPersonalNumber)
           , singletonMap "supervisors"      $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors
           , singletonMap "reroutes"         $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute
+          , singletonMap "usr-reason"       $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason)
+          , singletonMap "priority"         $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority)
           ]
         dbtFilter = mconcat
           [ single $ fltrUserNameEmail queryUserUser
@@ -905,33 +928,63 @@ mkFirmUserTable isAdmin cid = do
                         usrSpr <- E.from $ E.table @UserSupervisor
                         E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
                             E.&&.  usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria
+          , singletonMap "is-primary-company" $ FilterColumn $ \row (getLast -> criterion) ->
+              let checkPrimary = do
+                    other <- E.from $ E.table @UserCompany
+                    E.where_ $ other E.^. UserCompanyUser     E.==. queryUserUserCompany row E.^. UserCompanyUser
+                        E.&&.  other E.^. UserCompanyPriority E.>.  queryUserUserCompany row E.^. UserCompanyPriority
+              in case criterion of
+                  Nothing     -> E.true
+                  Just False  -> E.exists    checkPrimary
+                  Just True   -> E.notExists checkPrimary
           ]
         -- superField = selectField $ ????
         dbtFilterUI mPrev = mconcat
           [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
           -- , prismAForm (singletonFilter "supervisor-is"          . maybePrism _PathPiece)     mPrev $ aopt (hoistField lift supervisorField)  (fslI MsgFilterSupervisor)
           , prismAForm (multiFilter     "supervisors-are"        . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip)
-          , prismAForm (singletonFilter "has-supervisor"         . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor)
+          , prismAForm (singletonFilter "has-supervisor"         . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI   MsgFilterSupervisor)
           , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh)
           , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh)
+          , prismAForm (singletonFilter "is-primary-company"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI   MsgFilterFirmPrimary)
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
+        userReasons :: HandlerFor UniWorX (OptionList Text)
+        userReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
+          fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
+            usrc <- E.from $ E.table @UserCompany
+            E.where_ $ E.isJust (usrc E.^. UserCompanyReason)
+                  E.&&. usrc E.^. UserCompanyCompany E.==. E.val cid
+            return $ usrc E.^. UserCompanyReason
+        superReasons :: HandlerFor UniWorX (OptionList Text)
+        superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
+          fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
+            usrc <- E.from $ E.table @UserSupervisor
+            E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
+                  E.&&. usrc E.^. UserSupervisorCompany E.~=. E.val cid
+            return $ usrc E.^. UserSupervisorReason
         acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
         acts = mconcat
           [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
           , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
-              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)         (Just $ Just False)
+              <$> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
-              -- <*> aopt checkBoxField                                      (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
           , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
               <$> aopt (textField & cfAnySeparatedSet)                    (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
               <*> aopt supervisorsField                                   (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip)                          Nothing
-              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
+              <*> aopt (textField & cfStrip & addDatalist superReasons)   (fslI MsgUserSupervisorReason  & setTooltip MsgUserSupervisorReasonTooltip)         Nothing
-              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                                                     (Just False)
+              <*> areq  boolField'                                        (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
+              <*> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
           , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
               <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
           , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
-              <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
+              <$> aopt htmlField        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
-              <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
+              <*> aopt boolField'       (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
+              <*> aopt postalEmailField (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
+          , singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData
+              <$> aopt intField                                           (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
+              <*> aopt (textField & cfStrip & addDatalist userReasons)    (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
+          , singletonMap FirmUserActRemove $ FirmUserActRemoveData
+              <$> areq boolField'       (fslI MsgFirmActRemoveSupers) (Just True)
           ]
         dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
@@ -998,6 +1051,10 @@ postFirmUsersR fsh = do
       --     return usr
       <*> mkFirmUserTable isAdmin cid
 
+  let resetSupers :: Maybe Bool -> NonEmpty UserId -> DB Int64
+      resetSupers Nothing      _    = return 0
+      resetSupers (Just False) uids = deleteDefaultSupervisorsForUsers [] [] uids
+      resetSupers (Just True ) uids = deleteWhereCount [UserSupervisorUser <-. toList uids]
   formResult fusrRes $ \case
     (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
     (FirmUserActNotifyData , uids) -> do
@@ -1005,10 +1062,8 @@ postFirmUsersR fsh = do
       redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
     (FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do  -- set guaranteed to be non-empty due to first case clause
       runDB $ do
-        delSupers <- if firmUserActResetKeepOldSupers == Just False
+        delSupers <- resetSupers firmUserActResetSupers uids
-          then deleteSupervisors uids
+        newSupers <- addDefaultSupervisors Nothing cid uids
-          else return 0
-        newSupers <- addDefaultSupervisors cid uids
         addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
     (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do
@@ -1026,27 +1081,55 @@ postFirmUsersR fsh = do
                   <li>#{usr}
               |]
         in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
-      delSupers <- runDB
+      delSupers <- runDB $ resetSupers firmUserActResetSupers uids
-         $ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep
+        <* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) firmUserActSetSuperReason | u <- toList uids, s <- newSupers]
-        <* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers]
       addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
-
     (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
-      nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
+      nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
-      addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing
+      addMessageI Success $ MsgFirmActAddSupersSet nrUpd Nothing
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
-    (FirmUserActChangeContactData{..}, Set.toList -> uids) ->
+    (FirmUserActChangeDetailsData{..}, Set.toList -> uids) -> do
-      let changes = catMaybes
+      let upReason = case canonical firmUserActDetailReason of
-            [ (UserPostAddress   =.) . Just <$> canonical firmUserActPostalAddr  -- note that Nothing means no change and not delete address!
+                      Nothing     -> Nothing
-            , (UserPrefersPostal =.)        <$>           firmUserActPostalPref
+                      Just "NULL" -> Just $ UserCompanyReason =. Nothing
-            ]
+                      other       -> Just $ UserCompanyReason =. other
-      in unless (null changes) $ do
+      nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority]
-        nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes
+      let total = fromIntegral $ length uids
-        addMessageI Success $ MsgFirmUserChanges nrChanged
+          allok = bool Warning Success $ nrUpd == total
+      addMessageI allok $ MsgFirmUserActChangeDetailsResult nrUpd total
+      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
+    (FirmUserActChangeContactData{..}, Set.toList -> uids)
+      | firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr ->
+          addMessageI Error MsgCompanyUserUseCompanyPostalError
+      | otherwise -> do
+        let changes = catMaybes
+              [ toMaybe (firmUserActUseCompanyPostal == Just True) (UserPostAddress =. Nothing) -- precondition ensures that only one update applies for UserPostAddress
+              , (UserPostAddress   =.) . Just <$> canonical firmUserActPostalAddr               -- note that Nothing means no change and not delete address!
+              , (UserPrefersPostal =.)        <$>           firmUserActPostalPref
+              ]
+        nrChanged <- runDB $ do
+          nrUsrChange <- updateWhereCount [UserId <-. uids] changes
+          nrUseComp   <- case firmUserActUseCompanyPostal of
+            Just x  -> updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanyUseCompanyAddress =. x]
+            Nothing -> return 0
+          return $ max nrUsrChange nrUseComp
+        let total = fromIntegral $ length uids
+            allok = bool Warning Success $ nrChanged == total
+        addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
         reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
+    (FirmUserActRemoveData{..}, Set.toList -> uids) -> do
+      let optRemove = if firmUserActRemoveSupers then id else const $ return 0
+      (nrUc, nrSuper, nrSubs) <- runDB $ (,,)
+        <$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser       <-. uids])
+      let total = fromIntegral $ length uids
+          allok = bool Warning Success $ total == nrUc
+      addMessageI allok $ someMessages [MsgFirmUserActRemoveResult nrUc, MsgFirmRemoveSupervision nrSuper nrSubs]
+      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
 
-  formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser]
+  formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
 
   siteLayout (citext2widget companyName) $ do
     setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
@@ -1073,7 +1156,7 @@ data FirmSuperActionData = FirmSuperActNotifyData
                             , firmSuperActSwitchReroute :: Maybe Bool
                             }
                          | FirmSuperActRMSuperDefData
-                            { firmSuperActRMSuperActive :: Maybe Bool }
+                            { firmSuperActRMSuperActive ::       Bool }
 
   deriving (Eq, Ord, Show, Generic)
 
@@ -1089,6 +1172,7 @@ querySuperUserCompany = $(sqlLOJproj 2 2)
 type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64
                                     , [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]
                                     , E.Value (Maybe Bool), E.Value (Maybe Bool)   -- Maybe (Entity UserCompany)
+                                    , E.Value Bool
                                     )
 
 resultSuperUser :: Lens' SuperCompanyTableData (Entity User)
@@ -1109,6 +1193,9 @@ resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue
 resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool)
 resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue
 
+resultSuperCompanySuperior :: Lens' SuperCompanyTableData Bool
+resultSuperCompanySuperior = _dbrOutput . _7 . _unValue
+
 instance HasEntity SuperCompanyTableData User where
   hasEntity = resultSuperUser
 
@@ -1120,27 +1207,31 @@ mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Se
 mkFirmSuperTable isAdmin cid = do
   msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
   let
+    reasonSuperior = tshow SupervisorReasonAvsSuperior
     -- fsh = unCompanyKey cid
     resultDBTable = DBTable{..}
       where
         dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do
           EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid
-          E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
+          E.where_ $  E.isTrue (usrCmp E.?. UserCompanySupervisor) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
-              E.||.  E.exists (firmQuerySupervisedBy cid Nothing usr)
+          -- let uc_reason = E.joinV (usrCmp E.?. UserCompanyReason)
           return ( usr
                  , usr & firmCountForSupervisor cid Nothing
                  , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
                  , usrCmp E.?. UserCompanySupervisor
                  , usrCmp E.?. UserCompanySupervisorReroute
+                 -- , (E.isJust uc_reason E.&&. uc_reason E.==. E.justVal reasonSuperior) -- NOTE: this is problematic, as obvious approaches caused errors such as: Failed to parse Haskell type bool, received PersistNull, since the SQL comparison with NULL returns NULL
+                 , (E.coalesceDefault [E.joinV (usrCmp E.?. UserCompanyReason)] (E.val mempty) E.==. E.val reasonSuperior) -- works as well
+                    E.||. E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.justVal reasonSuperior)) usr)
                  )
         dbtRowKey = querySuperUser >>> (E.^. UserId)
-        dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do
+        dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute, isSuperior) -> do
             cmps <- E.select $ 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.==. E.val (entityKey usr)
               E.orderBy [E.asc $ cmp E.^. CompanyName]
               return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor)
-            return (usr, supervised, rerouted, cmps, supervisor, reroute)
+            return (usr, supervised, rerouted, cmps, supervisor, reroute, isSuperior)
         dbtColonnade = formColonnade $ mconcat
           [ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
           , colUserNameModalHdr MsgTableSupervisor ForProfileDataR
@@ -1152,7 +1243,11 @@ mkFirmSuperTable isAdmin cid = do
           , colUserEmail
           , sortable (Just "supervised")  (i18nCell MsgTableCompanyNrEmpSupervised)  $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
           , sortable (Just "rerouted")    (i18nCell MsgTableCompanyNrEmpRerouted  )  $ \(view resultSuperCompanyReroutes   -> nr) -> wgtCell $ word2widget nr
-          , sortable (Just "def-super")   (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper   -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell }
+          , sortable (Just "def-super")   (i18nCell MsgTableIsDefaultSupervisor) $ view resultSuperCompanyDefaultSuper >>> \case
+              Nothing      -> iconCell IconSupervisorForeign
+              (Just True ) -> iconCell IconSupervisor
+              (Just False) -> iconSpacerCell
+          , sortable Nothing  (i18nCell MsgTableSuperior) $ view resultSuperCompanySuperior >>> flip ifIconCell IconSuperior
           , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute)    $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True)
           , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr
           ]
@@ -1175,20 +1270,40 @@ mkFirmSuperTable isAdmin cid = do
           ]
         dbtFilter = mconcat
           [ single $ fltrUserNameEmail querySuperUser
+          , singletonMap "is-foreign-supervisor" $ FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) ->
+              case criterion of
+                  Nothing     -> E.true
+                  Just True   -> E.isNothing $ suc E.?. UserCompanyUser
+                  Just False  -> E.isJust    $ suc E.?. UserCompanyUser
+          , singletonMap "super-relation-foreign" $ FilterColumn $ \row (getLast -> criterion) ->
+              let checkSuper = do
+                    usrSpr <- E.from $ E.table @UserSupervisor
+                    E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId
+                        E.&&.  E.exists (do
+                                  usr <- E.from $  E.table @UserCompany
+                                  E.where_ $ usr E.^. UserCompanyCompany E.!=. E.val cid
+                                    E.&&.    usr E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorUser
+                                )
+              in case criterion of
+                  Nothing     -> E.true
+                  Just True   -> E.exists    checkSuper
+                  Just False  -> E.notExists checkSuper
           ]
         dbtFilterUI mPrev = mconcat
           [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev
+          , prismAForm (singletonFilter "is-foreign-supervisor"   . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperForeign)
+          , prismAForm (singletonFilter "super-relation-foreign"  . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterIsForeignSupervisee)
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
         acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
         acts = mconcat
           [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
           , singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData
-              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor)  (Just $ Just True)
+              <$> aopt boolField' (fslI MsgFirmSuperDefault)  (Just $ Just True)
-              <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute)      Nothing
+              <*> aopt boolField' (fslI MsgTableIsDefaultReroute)      Nothing
               <*  aformMessage msgSupervisorUnchanged
           , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
-              <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
+              <$> areq boolField' (fslI MsgFirmSuperActRMSuperActive) (Just True)
           ]
         dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
@@ -1232,19 +1347,14 @@ postFirmSupersR fsh = do
   formResult fsprRes $ \case
     (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
     (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
-      (nrRmSuper,nrRmActual) <- runDB $ (,)
+      let optRemove = if firmSuperActRMSuperActive then id else const $ return 0
+      (nrRmSuper,nrRmSupers,nrRmSubs) <- runDB $ (,,)
         <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
-        <*> if firmSuperActRMSuperActive /= Just True
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
-              then return 0
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser       <-. uids])
-              else E.deleteCount $ do
+      let total = fromIntegral $ length uids
-                spr <- E.from $ E.table @UserSupervisor
+          allok = bool Warning Success $ total == nrRmSuper
-                E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids
+      addMessageI allok $ someMessages [MsgRemoveSupervisors nrRmSuper, MsgFirmRemoveSupervision nrRmSupers nrRmSubs]
-                    E.&&. E.exists (do
-                      usr <- E.from $ E.table @UserCompany
-                      E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
-                          E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
-                    )
-      addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
     (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do
       let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of
@@ -1262,9 +1372,9 @@ postFirmSupersR fsh = do
       cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
       redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
 
-  formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm]
+  formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm]
 
-  siteLayout (citext2widget fsh) $ do
+  siteLayout (citext2widget companyName) $ do
     setTitle $ citext2Html $ fsh <> " Supers"
     let firmContactInfo = $(widgetFile "firm-contact-info")
     $(i18nWidgetFile "firm-supervisors")
@@ -1299,14 +1409,14 @@ handleFirmCommR ultDest cs = do
     csKeys = CompanyKey <$> cs
   mbUser <- maybeAuthId
   -- get employees of chosen companies
-  empys <- mkCompanyUsrList <$> runDB (E.select $ do
+  empys <- mkCompanyUsrList <$> runDBRead (E.select $ do
       (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
       E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
       E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
       return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
     )
   -- get supervisors of employees
-  sprs <- mkCompanyUsrList <$> runDB (E.select $ do
+  sprs <- mkCompanyUsrList <$> runDBRead (E.select $ do
       (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
       E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
         E.||. (spr E.^. UserId E.=?. E.val mbUser)

src/Handler/Health.hs

@@ -6,6 +6,7 @@ module Handler.Health where
 
 import Import
 
+import Data.Time.Format.ISO8601 (iso8601Show)
 import Handler.Utils.DateTime (formatTimeW)
 
 import qualified Data.Aeson.Encode.Pretty as Aeson
@@ -19,6 +20,9 @@ import Control.Concurrent.STM.Delay
 
 import System.Environment (lookupEnv) -- while git version number is not working
 
+import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.PostgreSQL as E  (now_)
+
 -- import Data.FileEmbed (embedStringFile)
 
 getHealthR :: Handler TypedContent
@@ -113,8 +117,16 @@ getInstanceR = do
 getStatusR :: Handler Html
 getStatusR = do
   starttime <- getsYesod appStartTime
-  (currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
+  dbTime <- runDBRead $ E.selectOne $ return E.now_
+  (currtime,env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
   -- ft <- formatTime'  "%Y-%m-%d %H:%M:%S" currtime
+  let diffTime :: UTCTime -> Text
+      diffTime t =
+        let tdiff = diffUTCTime currtime t
+        in if 64 > abs tdiff
+            then tshow tdiff
+            else pack . iso8601Show . calendarTimeTime . fromIntegral $ truncate tdiff
+
   withUrlRenderer
     [hamlet|
       $doctype 5
@@ -126,21 +138,23 @@ getStatusR = do
             <p>
               Environment version #{env_ver}
           <p>
-            Current Time <br> 
+            Current Application Time <br>
             #{show currtime} <br>
+          $maybe dbtval <- dbTime
+            $with dbt <- E.unValue dbtval
+              Current Database Time <br>
+              #{show dbt} #
+              Difference: #{diffTime dbt} <br>
           <p>
             Instance Start <br>
             #{show starttime} #
-            Uptime: #{show $ ddays starttime currtime} days.
+            Uptime: #{diffTime starttime}
           <p>
             Compile Time <br>
             #{show cTime} #
-            Build age: #{show $ ddays cTime currtime} days.
+            Build age: #{diffTime cTime}
     |]
   where
     -- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction
     cTime :: UTCTime
     cTime = $compileTime
-
-    ddays :: UTCTime -> UTCTime -> Double
-    ddays tstart tstop = (/100) $ fromIntegral $ round $ diffUTCTime tstop tstart / (36 * 24)

src/Handler/Health/Interface.hs

@@ -8,12 +8,14 @@ module Handler.Health.Interface
     getHealthInterfaceR
   , mkInterfaceLogTable
   , runInterfaceChecks
+  , getConfigInterfacesR, postConfigInterfacesR
   )
  where
 
 import Import
 
--- import qualified Data.Set as Set
+import qualified Data.Set as Set
+import qualified Data.Map as Map
 import qualified Data.Text as Text
 import Handler.Utils
 import Handler.Utils.Concurrent
@@ -24,6 +26,8 @@ import qualified Database.Esqueleto.Utils as E
 import qualified Database.Esqueleto.Legacy as EL (on)
 import qualified Database.Persist.Sql as E (deleteWhereCount)
 
+defaultInterfaceWarnHours :: Int
+defaultInterfaceWarnHours = 3 * 24      -- if no warn time can be found, use 3 days instead
 
 -- | identify a wildcard argument
 wc2null :: Text -> Maybe Text
@@ -33,6 +37,12 @@ wc2null "_" = Nothing
 wc2null "*" = Nothing
 wc2null  o  = Just o
 
+warnIntervalCell :: (IsDBTable m b, Integral a) => a -> DBCell m b
+warnIntervalCell x
+  | x >= 0      = textCell $ formatDiffHours x
+  | x <= (-100) = i18nCell MsgInterfaceWarningDisabledEntirely
+  | otherwise   = i18nCell MsgInterfaceWarningDisabledInterval
+
 -- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool
 pbool :: Text -> Maybe Bool
 pbool (Text.toLower . Text.strip -> w)
@@ -88,12 +98,7 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do               -- for bac
 
 runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
 runInterfaceLogTable interfs@(reqIfs,_) = do
-  -- we abuse messageTooltip for colored icons here
+  (res, twgt) <- runDB $ mkInterfaceLogTable interfs
-  msgSuccessTooltip <- messageI Success MsgMessageSuccess
-  -- msgWarningTooltip <- messageI Warning MsgMessageWarning
-  msgErrorTooltip   <- messageI Error   MsgMessageError
-  let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
-  (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
   let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
       allok   = all snd res
   return (missing, allok, res, twgt)
@@ -101,12 +106,14 @@ runInterfaceLogTable interfs@(reqIfs,_) = do
 -- ihDebugShow :: Unique InterfaceHealth -> Text
 -- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")"
 
-mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
+mkInterfaceLogTable :: ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
-mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
+mkInterfaceLogTable interfs@(reqIfs, banIfs) = do
     --   $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
-    void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
+    flagError <- liftHandler $ do
+      void $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs -- ensure interface checkc are up to date
+      mkErrorFlag
     now <- liftIO getCurrentTime
-    dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
+    dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now flagError, ..}
   where
     sanitize      = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü']
     dbtIdent      = "interface-log" :: Text
@@ -115,7 +122,16 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
       EL.on (       ilog E.^. InterfaceLogInterface E.=?.          ihealth E.?. InterfaceHealthInterface
               E.&&. ilog E.^. InterfaceLogSubtype   E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
               E.&&. ilog E.^. InterfaceLogWrite     E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite  )
-            )
+              E.&&. E.notExists (do -- a more specific match does not exist
+                  otherh <- E.from $ E.table @InterfaceHealth
+                  E.where_ $ ilog    E.^. InterfaceLogInterface E.==.         otherh E.^. InterfaceHealthInterface
+                      E.&&.  ilog    E.^. InterfaceLogSubtype   E.=~.         otherh E.^. InterfaceHealthSubtype
+                      E.&&.  ilog    E.^. InterfaceLogWrite     E.=~.         otherh E.^. InterfaceHealthWrite
+                      E.&&.  ihealth E.?. InterfaceHealthHours  E.!=. E.just (otherh E.^. InterfaceHealthHours)
+                      E.&&.  (E.isNothing (E.joinV $ ihealth E.?. InterfaceHealthSubtype)
+                        E.||. E.isNothing (E.joinV $ ihealth E.?. InterfaceHealthWrite  ))
+                    )
+                )
       let matchUIH crits = E.or
            [ E.and $ catMaybes
              [  ilog E.^. InterfaceLogInterface E.==.    E.val  (sanitize     ifce) & Just
@@ -139,32 +155,34 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
       -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&.  ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD  All missing, except for "Printer" "F"
       -- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&.  ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY
       -- E.where_ $         ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||.  ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F")  -- WORKS OKAY
-      let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24)  -- if no default time is set, use 3 days instead
+      let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours)  -- if no default time is set, use a default instead
       return (ilog, ihour)
 
     queryILog     :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog)
     queryILog     = $(E.sqlLOJproj 2 1)
+    queryHealth   :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Maybe (Entity InterfaceHealth))
+    queryHealth   = $(E.sqlLOJproj 2 2)
     resultILog    :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog
     resultILog    = _dbrOutput . _1 . _entityVal
     resultHours   :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int
     resultHours   = _dbrOutput . _2 . E._unValue
 
     dbtRowKey     = queryILog >>> (E.^.InterfaceLogId)
-    colonnade now = mconcat
+    colonnade now flagError = mconcat
         [ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do
             let hours   = row ^. resultHours
                 -- defmsg  = row ^? resultErrMsg
                 logtime = row ^. resultILog . _interfaceLogTime
                 success = row ^. resultILog . _interfaceLogSuccess
                 iface   = row ^. resultILog . _interfaceLogInterface
-                status  = success && now <= addHours hours logtime
+                status  = (success || hours <= -100) && (hours < 0 || now <= addHours hours logtime)
-            in tellCell [(iface,status)] $
+            in tellCell [(iface,status)] $ wgtCell $ flagError $ toMaybe (success || not status) status
-                wgtCell $ flagError status
         , sortable (Just "interface") (i18nCell MsgInterfaceName      ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
         , sortable (Just "subtype")   (i18nCell MsgInterfaceSubtype   ) $ textCell . view (resultILog . _interfaceLogSubtype)
         , sortable (Just "write")     (i18nCell MsgInterfaceWrite     ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
         , sortable (Just "time")      (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
-        , sortable Nothing            (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
+        , sortable (Just "hours")     (i18nCell MsgInterfaceFreshness & cellTooltips [SomeMessage MsgInterfaceFreshnessTooltip, SomeMessage MsgTableDiffDaysTooltip]
+                                                                      ) $ warnIntervalCell . view resultHours
         , sortable (Just "rows")      (i18nCell MsgTableRows          ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
         , sortable (Just "success")   (i18nCell MsgInterfaceSuccess   ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s
         , sortable Nothing            (i18nCell MsgInterfaceInfo      ) $ \(view resultILog -> ilt) -> case ilt of
@@ -180,6 +198,7 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
         , singletonMap "time"      $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime)
         , singletonMap "rows"      $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows)
         , singletonMap "success"   $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess)
+        , singletonMap "hours"     $ SortColumn $ \r -> E.coalesceDefault [queryHealth r E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours)
         ]
     ilvalidator   = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
     dbtFilter     = mempty
@@ -249,3 +268,135 @@ avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (
       -- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
       writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime
     _ -> return ()
+
+
+
+data IWTableAction
+    = IWTActAdd
+    | IWTActDelete
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+instance Universe IWTableAction
+instance Finite   IWTableAction
+nullaryPathPiece ''IWTableAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''IWTableAction id
+
+data IWTableActionData
+    = IWTActAddData
+        { iwtActInterface :: Text
+        , iwtActSubtype   :: Maybe Text
+        , iwtActWrite     :: Maybe Bool
+        , iwtActHours     :: Int
+        }
+    | IWTActDeleteData
+  deriving (Eq, Ord, Read, Show, Generic)
+
+type IWTableExpr = E.SqlExpr (Entity InterfaceHealth)
+
+queryInterfaceHealth :: IWTableExpr -> E.SqlExpr (Entity InterfaceHealth)
+queryInterfaceHealth = id
+
+type IWTableData = DBRow (Entity InterfaceHealth)
+
+resultInterfaceHealth :: Lens' IWTableData (Entity InterfaceHealth)
+resultInterfaceHealth = _dbrOutput
+
+wildcardCell :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b
+wildcardCell _ Nothing  = iconFixedCell $ icon IconWildcard
+wildcardCell c (Just x) = c x
+
+mkInterfaceWarnTable :: DB (FormResult (IWTableActionData, Set InterfaceHealthId), Widget)
+mkInterfaceWarnTable = do
+  let
+    mkOption :: E.Value Text -> Option Text
+    mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
+    getSuggestion pj = E.select $ E.distinct $ do
+      il <- E.from $ E.table @InterfaceLog
+      let res = il E.^. pj
+      E.orderBy [E.asc res]
+      pure res
+    suggestionInterface :: HandlerFor UniWorX (OptionList Text)
+    suggestionInterface = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogInterface)
+    suggestionSubtype   :: HandlerFor UniWorX (OptionList Text)
+    suggestionSubtype   = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogSubtype)
+    dbtIdent = "interface-warnings" :: Text
+    dbtSQLQuery :: IWTableExpr -> E.SqlQuery IWTableExpr
+    dbtSQLQuery = return
+    dbtRowKey = queryInterfaceHealth >>> (E.^. InterfaceHealthId)
+    dbtProj = dbtProjId
+    dbtColonnade = formColonnade $ mconcat
+      [ dbSelect (applying _2) id (return . view (resultInterfaceHealth . _entityKey))
+      , sortable (Just "interface") (i18nCell MsgInterfaceName      ) $ \(view (resultInterfaceHealth . _entityVal . _interfaceHealthInterface) -> n) -> textCell n
+      , sortable (Just "subtype")   (i18nCell MsgInterfaceSubtype   ) $ wildcardCell textCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthSubtype )
+      , sortable (Just "write")     (i18nCell MsgInterfaceWrite     ) $ wildcardCell (iconFixedCell . iconWriteReadOnly) . view (resultInterfaceHealth . _entityVal . _interfaceHealthWrite   )
+      -- , sortable (Just "hours")     (i18nCell MsgInterfaceFreshness ) $ numCell                               . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours   )
+      , sortable (Just "hours")     (i18nCell MsgInterfaceFreshness
+                              & cellTooltip MsgTableDiffDaysTooltip ) $ warnIntervalCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours   )
+      ]
+    dbtSorting = mconcat
+      [ singletonMap "interface" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthInterface)
+      , singletonMap "subtype"   $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthSubtype)
+      , singletonMap "write"     $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthWrite)
+      , singletonMap "hours"     $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthHours)
+      ]
+    dbtFilter     = mempty
+    dbtFilterUI   = mempty
+    dbtStyle      = def { dbsFilterLayout = defaultDBSFilterLayout }
+    dbtParams     = DBParamsForm
+      { dbParamsFormMethod = POST
+      , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
+      , dbParamsFormAttrs  = []
+      , dbParamsFormSubmit = FormSubmit
+      , dbParamsFormAdditional
+          = let acts :: Map IWTableAction (AForm Handler IWTableActionData)
+                acts = mconcat
+                  [ singletonMap IWTActAdd    $      IWTActAddData
+                      <$> apreq (textField & cfStrip & addDatalist suggestionInterface) (fslI MsgInterfaceName)       Nothing
+                      <*> aopt  (textField & cfStrip & addDatalist suggestionSubtype)   (fslI MsgInterfaceSubtype)    Nothing
+                      <*> aopt   boolField'                                             (fslI MsgInterfaceWrite)      Nothing
+                      <*> apreq  intField                                               (fslI MsgInterfaceFreshness & setTooltip MsgHours)  Nothing
+                  , singletonMap IWTActDelete $ pure IWTActDeleteData
+                  ]
+             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 IWTableActionData, DBFormResult InterfaceHealthId Bool IWTableData)
+                -> FormResult (      IWTableActionData,          Set InterfaceHealthId)
+    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 "interface", SortAscBy "subtype", SortAscBy "write"]
+  over _1 postprocess <$> dbTable psValidator DBTable{..}
+
+getConfigInterfacesR,  postConfigInterfacesR :: Handler Html
+getConfigInterfacesR = postConfigInterfacesR
+postConfigInterfacesR = do
+  ((interfaceOks, interfaceTable), (warnRes, configTable)) <- runDB $ (,)
+    <$> mkInterfaceLogTable mempty
+    <*> mkInterfaceWarnTable
+  let interfacesBadNr = length $ filter (not . snd) interfaceOks
+  formResult warnRes $ \case
+    (IWTActAddData{..}, _) -> do
+      void $ runDB $ upsertBy
+        (UniqueInterfaceHealth iwtActInterface iwtActSubtype iwtActWrite)
+        (      InterfaceHealth iwtActInterface iwtActSubtype iwtActWrite iwtActHours)
+        [InterfaceHealthHours =. iwtActHours]
+      addMessageI Success MsgInterfaceWarningAdded
+      reloadKeepGetParams ConfigInterfacesR
+    (IWTActDeleteData, ihids) -> do
+      runDB $ mapM_ delete ihids
+      addMessageI Success $ MsgInterfaceWarningDeleted $ Set.size ihids
+      reloadKeepGetParams ConfigInterfacesR
+
+  siteLayoutMsg MsgConfigInterfacesHeading $ do
+    setTitleI MsgConfigInterfacesHeading
+    let defWarnTime = formatDiffHours defaultInterfaceWarnHours
+    $(i18nWidgetFile "config-interfaces")

src/Handler/LMS.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -149,12 +149,20 @@ mkLmsAllTable isAdmin lmsDeletionDays = do
           , sortable Nothing (i18nCell MsgQualificationRefreshWithin    & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip  , SomeMessage MsgTableDiffDaysTooltip]) $
               foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshWithin)
           -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin)   $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
+          , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row ->
+              let elearnstart = row ^. resultAllQualification . _qualificationElearningStart
+                  reminder    = row ^. resultAllQualification . _qualificationRefreshReminder
+              in tickmarkCell $ elearnstart && isJust reminder
           , sortable Nothing (i18nCell MsgQualificationRefreshReminder  & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
               foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshReminder)
           , sortable Nothing (i18nCell MsgQualificationAuditDuration    & cellTooltips [SomeMessage (MsgQualificationAuditDurationTooltip lmsDeletionDays), SomeMessage MsgTableDiffDaysTooltip]) $
               foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
-          , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
+          , sortable (Just "qel-renew")  (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew)
-                                                                        $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
+                                                                        $ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews)
+          , sortable (Just "qel-limit")  (i18nCell MsgTableLmsElearningLimit & cellTooltip MsgQualificationElearningLimit)
+                                                                        $ cellMaybe numCell . view (resultAllQualification . _qualificationElearningLimit)
+          , sortable (Just "qel-reuse")  (i18nCell MsgTableQualificationLmsReuses & cellTooltip MsgTableQualificationLmsReusesTooltip)
+                  $ \(view (resultAllQualification . _qualificationLmsReuses) -> reuseQid) -> maybeCell reuseQid qualificationIdShortCell
           , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
                   $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
           , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
@@ -175,6 +183,9 @@ mkLmsAllTable isAdmin lmsDeletionDays = do
           , singletonMap "qshort"       $ SortColumn (E.^. QualificationShorthand)
           , singletonMap "qname"        $ SortColumn (E.^. QualificationName)
           , singletonMap "qelearning"   $ SortColumn (E.^. QualificationElearningStart)
+          , singletonMap "qel-renew"    $ SortColumn (E.^. QualificationElearningRenews)
+          , singletonMap "qel-limit"    $ SortColumn (E.^. QualificationElearningLimit)
+          , singletonMap "qel-reuse"    $ SortColumn (E.^. QualificationLmsReuses)
           ]
         dbtFilter = mconcat
           [
@@ -209,7 +220,6 @@ data LmsTableCsv = LmsTableCsv   -- L..T..C.. -> ltc..
   { ltcDisplayName    :: UserDisplayName
   , ltcEmail          :: UserEmail
   , ltcCompany        :: Maybe Text
-  , ltcCompanyNumbers :: CsvSemicolonList Int
   , ltcValidUntil     :: Day
   , ltcLastRefresh    :: Day
   , ltcFirstHeld      :: Day
@@ -231,8 +241,7 @@ ltcExample :: LmsTableCsv
 ltcExample = LmsTableCsv
     { ltcDisplayName    = "Max Mustermann"
     , ltcEmail          = "m.mustermann@example.com"
-    , ltcCompany        = Just "Example Brothers LLC, SecondaryJobs Inc"
+    , ltcCompany        = Just "Example Brothers LLC"
-    , ltcCompanyNumbers = CsvSemicolonList [27,69]
     , ltcValidUntil     = succ compDay
     , ltcLastRefresh    = compDay
     , ltcFirstHeld      = pred $ pred compDay
@@ -274,8 +283,7 @@ instance CsvColumnsExplained LmsTableCsv where
   csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
     [ ('ltcDisplayName    , SomeMessage MsgLmsUser)
     , ('ltcEmail          , SomeMessage MsgTableLmsEmail)
-    , ('ltcCompany        , SomeMessage MsgTableCompanies)
+    , ('ltcCompany        , SomeMessage MsgTablePrimeCompany)
-    , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos)
     , ('ltcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
     , ('ltcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
     , ('ltcFirstHeld      , SomeMessage MsgTableQualificationFirstHeld)
@@ -309,7 +317,7 @@ queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBloc
 queryQualBlock = $(sqlLOJproj 2 2)
 
 
-type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany], E.Value Bool)
+type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), E.Value (Maybe CompanyId), E.Value Bool)
 
 resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
 resultQualUser = _dbrOutput . _1
@@ -326,8 +334,8 @@ resultQualBlock = _dbrOutput . _4 . _Just
 resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
 resultPrintAck = _dbrOutput . _5 . _unValue . _Just
 
-resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
+resultCompanyId :: Traversal' LmsTableData CompanyId
-resultCompanyUser = _dbrOutput . _6
+resultCompanyId = _dbrOutput . _6 . _unValue . _Just
 
 resultValidQualification :: Lens' LmsTableData Bool
 resultValidQualification = _dbrOutput . _7 . _unValue
@@ -395,6 +403,7 @@ lmsTableQuery :: UTCTime -> QualificationId -> LmsTableExpr
                 , E.SqlExpr (Entity LmsUser)
                 , E.SqlExpr (Maybe (Entity QualificationUserBlock))
                 , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
+                , E.SqlExpr (E.Value (Maybe CompanyId))
                 , E.SqlExpr (E.Value Bool)
                 )
 lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
@@ -410,12 +419,16 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
     E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification
     -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
     let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
-                    E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
+          E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
-                        E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
+              E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
-                    let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
+          let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
-                    pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated     ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
+          pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated     ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
-                           E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder                                                        
+                  E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
-    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
+        primeComp = E.subSelect . E.from $ \uc -> do
+          E.where_ $ user E.^. UserId E.==. uc E.^. UserCompanyUser
+          E.orderBy [E.desc $ uc E.^. UserCompanyPriority, E.asc $ uc E.^. UserCompanyCompany]
+          return (uc E.^. UserCompanyCompany)
+    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, primeComp, validQualification now qualUser)
 
 
 mkLmsTable :: ( Functor h, ToSortable h
@@ -424,25 +437,26 @@ mkLmsTable :: ( Functor h, ToSortable h
            => Bool
            -> Entity Qualification
            -> Map LmsTableAction (AForm Handler LmsTableActionData)
-           -> (Map CompanyId Company -> cols)
+           -> ((CompanyId -> CompanyName) -> cols)
            -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
            -> DB (FormResult (LmsTableActionData, Set UserId), Widget)
 mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
   now <- liftIO getCurrentTime
   -- lookup all companies
-  cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do 
+  cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
     cmps <- selectList [] [] -- [Asc CompanyShorthand]
     return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
   let
+    getCompanyName :: CompanyId -> CompanyName
+    getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure
+
     csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
     dbtIdent :: Text
     dbtIdent = "lms"
     dbtSQLQuery = lmsTableQuery now qid
     dbtRowKey = queryUser >>> (E.^. UserId)
-    dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do
+    dbtProj = dbtProjId
-      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
+    dbtColonnade = cols getCompanyName
-      return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ)
-    dbtColonnade = cols cmpMap
     dbtSorting = mconcat
       [ single $ sortUserNameLink   queryUser
       , single $ sortUserEmail      queryUser
@@ -499,13 +513,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
                 E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                 E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
         )
-      , single ("avs-card"  , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
+      , fltrAVSCardNos queryUser
-            Nothing -> E.false
-            Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
-                E.on     $ usrAvs E.^. UserAvsPersonId  E.==. avsCard E.^. UserAvsCardPersonId  
-                E.where_ $ usrAvs E.^. UserAvsUser      E.==. user    E.^. UserId
-                    E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
-          )
       , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
           | Set.null criteria -> E.true
           | otherwise         -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
@@ -515,7 +523,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
       [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
       , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
       , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
-      , prismAForm (singletonFilter "avs-card" )        mPrev $ aopt textField (fslI MsgAvsCardNo)
+      , fltrAVSCardNosUI mPrev
       , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
       , prismAForm (singletonFilter "ident"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
       , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
@@ -539,25 +547,20 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
         doEncode' = LmsTableCsv
           <$>  view    (resultUser     . _entityVal . _userDisplayName)
           <*>  view    (resultUser     . _entityVal . _userDisplayEmail)
-          <*> (view     resultCompanyUser >>= getCompanies)
+          <*>  preview (resultCompanyId . to getCompanyName . _CI)
-          <*> (view     resultCompanyUser >>= getCompanyNos)
+          <*>  view    (resultQualUser  . _entityVal . _qualificationUserValidUntil)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
+          <*>  view    (resultQualUser  . _entityVal . _qualificationUserLastRefresh)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
+          <*>  view    (resultQualUser  . _entityVal . _qualificationUserFirstHeld)
-          <*>  view    (resultQualUser . _entityVal . _qualificationUserFirstHeld)
           <*>  preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not)
           <*>  preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserIdent)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserIdent)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStatus)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserStatus)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStatusDay)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserStatusDay)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStarted)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserStarted)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserDatePin)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserDatePin)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserReceived)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserReceived)
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
-          <*>  view    (resultLmsUser  . _entityVal . _lmsUserEnded)
+          <*>  view    (resultLmsUser   . _entityVal . _lmsUserEnded)
-        getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of 
-          []        -> pure   Nothing
-          somecmps  -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
-        getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
 
     dbtCsvDecode = Nothing
     dbtExtraReps = []
@@ -602,8 +605,9 @@ postLmsR sid qsh = do
   msgResetInfo      <- messageIconI Info    IconNotificationNonactive MsgLmsActResetInfo
   msgRestartWarning <- messageIconI Warning IconWarning               MsgLmsActRestartWarning
 
-  ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
+  ((lmsRes, lmsTable), Entity qid quali, lmsQualiReused) <- runDB $ do
-    qent <- getBy404 $ SchoolQualificationShort sid qsh
+    qent@Entity{entityVal=Qualification{qualificationLmsReuses = reuseQuali}} <- getBy404 $ SchoolQualificationShort sid qsh
+    lmsQualiReused <- traverseJoin get reuseQuali
     let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
         acts = mconcat
           [ singletonMap LmsActNotify       $ pure LmsActNotifyData
@@ -621,16 +625,12 @@ postLmsR sid qsh = do
               -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
               <*  aformMessage msgRestartWarning
           ]
-        colChoices cmpMap = mconcat
+        colChoices getCompanyName = mconcat
           [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
           , colUserNameModalHdrAdmin MsgLmsUser AdminUserR
           , colUserEmail
-          , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
+          , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
-              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
+              maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
-                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
-                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap                        
-                        ]
-              in intercalate spacerCell cs
           , colUserMatriclenr isAdmin
           -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
           , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
@@ -700,7 +700,7 @@ postLmsR sid qsh = do
             i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
         psValidator = def & defaultSorting [SortDescBy "started", SortDescBy "status"]
     tbl <- mkLmsTable isAdmin qent acts colChoices psValidator
-    return (tbl, qent)
+    return (tbl, qent, lmsQualiReused)
 
   formResult lmsRes $ \case
     _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
@@ -798,7 +798,7 @@ viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser
 viewLmsUserR msid mqsh uuid = do
   uid <- decrypt uuid
   now <- liftIO getCurrentTime
-  (user@User{userDisplayName}, quals, qblocks) <- runDB $ do 
+  (user@User{userDisplayName}, quals, qblocks) <- runDBRead $ do
     usr <- get404 uid
     qs  <- Ex.select $ do
           (qual :& qualUsr :& lmsUsr) <-

src/Handler/LMS/Fake.hs

@@ -67,15 +67,15 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
         let pw = "123.456"
         PWHashConf{..} <- getsYesod $ view _appAuthPWHash
         pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength
-        return $ TEnc.decodeUtf8 pwHash
+        return $ AuthPWHash $ TEnc.decodeUtf8 pwHash
     theSupervisor <- selectKeysList [UserSurname ==. "Jost", UserFirstName ==. "Steffen"] [Asc UserCreated, LimitTo 1]
     let addSupervisor = case theSupervisor of 
           [s] -> \suid k -> case k of 
-                    1 -> void $ insertBy $ UserSupervisor s suid True
+                    1 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing
                     2 -> do
-                          void $ insertBy $ UserSupervisor s    suid True
+                          void $ insertBy $ UserSupervisor s    suid True Nothing (Just "Test")
-                          void $ insertBy $ UserSupervisor suid suid True
+                          void $ insertBy $ UserSupervisor suid suid True Nothing Nothing
-                    3 -> void $ insertBy $ UserSupervisor s suid True
+                    3 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing
                     _ -> return ()
           _   -> \_ _ -> return ()
         expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)]
@@ -83,14 +83,15 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
         fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool, Int) -> User
         fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal, _isSupervised) =
           let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ (Text.take 1 <$> drop 1 firstNames) ++ [userSurname]) <> "@example.com"
-              userPasswordHash = Just pwSimple
-              userLastAuthentication = Nothing
               userEmail = userIdent
               userDisplayEmail = userIdent
               userDisplayName = Text.unwords $ firstNames <> [userSurname]
               userMatrikelnummer = Just "TESTUSER"
+              userAuthentication = pwSimple
+              userLastAuthentication = Nothing
               userCreated = now
-              userLastSync = Just now
+              userLastLdapSynchronisation = Nothing
+              userLdapPrimaryKey = Nothing
               userTokensIssuedAfter = Nothing
               userFirstName = Text.unwords firstNames
               userTitle = Nothing

src/Handler/LMS/Learners.hs

@@ -19,6 +19,7 @@ import Handler.Utils.LMS
 
 import qualified Data.Map as Map
 import qualified Data.Csv as Csv
+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
@@ -175,13 +176,16 @@ getLmsLearnersR sid qsh = do
 getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
 getLmsLearnersDirectR sid qsh = do
   $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
-  (lms_users,cutoff) <- runDB $ do
+  (lms_users,cutoff,qshs) <- runDB $ do
     (qid, cutoff) <- getQidCutoff sid qsh
-    lms_users <- selectList [ LmsUserQualification ==. qid
+    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]
-    return (lms_users, cutoff)
+    return (lms_users, cutoff, qshs)
 
     {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
       Ex.select $ do
@@ -209,7 +213,7 @@ getLmsLearnersDirectR sid qsh = do
       csvOpts = def { csvFormat = fmtOpts }
   csvSheetName <- csvFilenameLmsUser qsh
   let nr  = length lms_users
-      msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
+      msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows for Qualifications " <> Text.intercalate ", " (ciOriginal <$> qshs)
   $logInfoS "LMS" msg
   addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
   csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered

src/Handler/LMS/Report.hs

@@ -3,6 +3,7 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
+{-# LANGUAGE TypeApplications #-}
 
 module Handler.LMS.Report
   ( getLmsReportR, postLmsReportR
@@ -17,10 +18,13 @@ import Handler.Utils
 import Handler.Utils.Csv
 import Handler.Utils.LMS
 
+import qualified Data.Text as Text
 import qualified Data.Map as Map
 import qualified Data.Csv as Csv
 import qualified Data.Conduit.List as C
-import qualified Database.Esqueleto.Legacy as E
+-- import           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 
 import Jobs.Queue
@@ -246,8 +250,8 @@ postLmsReportR sid qsh = do
 
 -- Direct File Upload/Download
 
-saveReportCsv :: UTCTime -> QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
+saveReportCsv :: UTCTime -> NonEmpty QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
-saveReportCsv now qid i LmsReportTableCsv{..} = do    
+saveReportCsv now (qid :| []) i LmsReportTableCsv{..} = do
     void $ upsert
       LmsReport
         { lmsReportQualification  =  qid
@@ -263,6 +267,30 @@ saveReportCsv now qid i LmsReportTableCsv{..} = do
       , LmsReportTimestamp        =. now
       ]
     return $ succ i
+saveReportCsv now qids@(qid :| _) i lrtc@LmsReportTableCsv{..} = do
+    ok <- E.insertSelectWithConflictCount UniqueLmsReport
+      (do
+        lusr <- E.from $ E.table @LmsUser
+        E.where_ $ lusr E.^. LmsUserIdent         E.==. E.val csvLRident
+            E.&&.  lusr E.^. LmsUserQualification `E.in_` E.vals qids
+        return $ LmsReport
+          E.<#  (lusr E.^. LmsUserQualification)
+          E.<&> E.val  csvLRident
+          E.<&> E.val (csvLRdate <&> lms2timestamp)
+          E.<&> E.val  csvLRresult
+          E.<&> E.val (csvLRlock  & lms2bool)
+          E.<&> E.val  now
+      )
+      (\_old _new ->
+          [ LmsReportDate       E.=. E.val (csvLRdate <&> lms2timestamp)
+          , LmsReportResult     E.=. E.val  csvLRresult
+          , LmsReportLock       E.=. E.val (csvLRlock  & lms2bool)
+          , LmsReportTimestamp  E.=. E.val  now
+          ]
+      )
+    if ok > 0
+      then return $ succ i
+      else saveReportCsv now (qid :| []) i lrtc -- save unknown LmsIdent to primary qid regardless, so that the error can be tracked
 
 makeReportUploadForm :: Form FileInfo
 makeReportUploadForm = renderAForm FormStandard $ fileAFormReq "Report CSV"
@@ -276,15 +304,18 @@ postLmsReportUploadR sid qsh = do
     FormSuccess file -> do
       -- content <- fileSourceByteString file
       -- return $ Just (fileName file, content)
-      (nr, qid) <- runDBJobs $ do
+      (nr, qids, qshs) <- runDBJobs $ do
         qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
+        qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
+        let qids = qid :| (entityKey <$> qidsReuse)
+            qshs = qsh :  (qualificationShorthand . entityVal <$> qidsReuse)
         nr <- runConduit $ fileSource file
                 .| decodeCsv
-                .| foldMC (saveReportCsv now qid) 0        
+                .| foldMC (saveReportCsv now qids) 0
-        return (nr, qid)
+        return (nr, qids, qshs)
-      addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
+      addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") <> " für Qualifikationen: " <> Text.intercalate ", " (ciOriginal <$> qshs)
       -- redirect $ LmsReportR sid qsh
-      getLmsReportR sid qsh <* queueJob' (JobLmsReports qid) -- show uploaded data before processing
+      getLmsReportR sid qsh <* forM_ qids (queueJob' . JobLmsReports) -- show uploaded data before processing
 
     FormFailure errs -> do
       forM_ errs $ addMessage Error . toHtml
@@ -308,18 +339,21 @@ postLmsReportDirectR sid qsh = do
       lmsDecoder <- getLmsCsvDecoder
       runDBJobs $ do
         qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
+        qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
+        let qids = qid :| (entityKey <$> qidsReuse)
+            qshs = qsh :  (qualificationShorthand . entityVal <$> qidsReuse)
         enr <- try $ runConduit $ fileSource file
                 .| lmsDecoder
-                .| foldMC (saveReportCsv now qid) 0
+                .| foldMC (saveReportCsv now qids) 0
         case enr of
           Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
-            $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e
+            $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e <> " for Qualification: " <> Text.intercalate ", " (ciOriginal <$> qshs)
             logInterface "LMS" (ciOriginal qsh) False Nothing ""
             return (badRequest400, "Exception: " <> tshow e)
           Right nr -> do
-            let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ".  "
+            let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> " and Qualifications: " <> Text.intercalate ", " (ciOriginal <$> qshs)
             $logInfoS "LMS" msg
-            when (nr > 0) $ queueDBJob $ JobLmsReports qid
+            when (nr > 0) $ forM_ qids (queueDBJob . JobLmsReports)
             logInterface "LMS" (ciOriginal qsh) True (Just nr) ""
             return (ok200, msg)
     []     -> do

src/Handler/MailCenter.hs

@@ -0,0 +1,375 @@
+-- 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
+
+
+
+-- avoids repetition of local definitions
+single :: (k,a) -> Map k a
+single = uncurry Map.singleton
+
+
+data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+instance Universe MCTableAction
+instance Finite MCTableAction
+nullaryPathPiece ''MCTableAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''MCTableAction id
+
+data MCTableActionData  = MCActDummyData
+  deriving (Eq, Ord, Read, Show, Generic)
+
+
+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 = mconcat
+      [ single ("sent"      , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
+      , single ("recipient" , sortUserNameBareM queryRecipient)
+      ]
+    dbtFilter = mconcat
+      [ single ("sent"      , FilterColumn . E.mkDayFilterTo                        $ views (to queryMail)        (E.^. SentMailSentAt))
+      , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just   $ views (to queryRecipient)   (E.?. UserDisplayName))
+      , single ("subject"   , FilterColumn . E.mkContainsFilterWithCommaPlus id     $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
+      -- , single ("regex"     , FilterColumn . E.mkRegExFilterWith id                 $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
+      ]
+    dbtFilterUI mPrev = mconcat
+      [ prismAForm (singletonFilter "sent"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgPrintJobCreated)
+      , 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    )
+      ]
+    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 = FormNoSubmit
+      , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty)
+      -- , dbParamsFormSubmit = FormSubmit
+      -- , dbParamsFormAdditional
+      --     = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
+      --           acts = mconcat
+      --             [ singletonMap MCActDummy $ pure MCActDummyData
+      --             ]
+      --        in renderAForm FormStandard
+      --          $  (, mempty) . First . Just
+      --         <$> multiActionA acts (fslI MsgTableAction) Nothing
+      , dbParamsFormEvaluate = liftHandler . runFormPost
+      , dbParamsFormResult   = id
+      , dbParamsFormIdent    = def
+      }
+    postprocess :: FormResult (First 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
+    (MCActDummyData, Set.toList -> _smIds) -> do
+      addMessageI Success MsgBoolIrrelevant
+      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 (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml])  [typeHtml,typePlain]
+
+getMailPlainR :: CryptoUUIDSentMail -> Handler Html
+getMailPlainR = handleMailShow (SomeMessages [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