Merge branch 'fradrive/company' into test

2023-10-20 16:46:30 +00:00 · 2023-10-20 16:46:30 +00:00 · 6e5a58aa37
commit 6e5a58aa37
parent d495a31ad8 603f04f026
45 changed files with 1523 additions and 348 deletions
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@ -2,6 +2,70 @@

 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.

+## [27.4.45](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.44...v27.4.45) (2023-10-18)
+
+
+### Bug Fixes
+
+* **hoogle:** remove erroneous comment ([c011d88](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c011d887cece8338920355b540aa4b233e0b994f))
+* **sap:** yet another fix for finding date intervals ([fde97b0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fde97b048ab04ab59c9e3f2a2f74bb2c1e996b22))
+
+## [27.4.44](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.43...v27.4.44) (2023-10-18)
+
+
+### Bug Fixes
+
+* **sap:** combine immediate next day licence chnages for SAP ([f4adfdf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f4adfdf87270930d4ca6611f2a9956613fcace53))
+* **sap:** combine immediate next day licence chnages for SAP ([cbb44f1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cbb44f106ad59e0a53ca04963ade5544120b7e21))
+* **sap:** combineBlocks yet another bug squashed ([3924d14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3924d14abd868305b42c9d04913536b4999dc45b))
+* **sap:** compileBlocks ([b4a88ab](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4a88abcf85783c350ad2bf3a5e973d13d1eb1f6))
+
+## [27.4.43](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.42...v27.4.43) (2023-10-13)
+
+## [27.4.42](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.41...v27.4.42) (2023-10-12)
+
+
+### Bug Fixes
+
+* **build:** Update ParticipantInvite.hs ([f888da3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f888da3ab0df45bb3c515ebb7cbb43569fdaa1fa))
+* **build:** Update ParticipantInvite.hs ([fa4f9b2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa4f9b24475261afc1e534541c8878a85e6a1b10))
+* **build:** Update Utils.hs ([87f0b2e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/87f0b2edab2bcf696b7b776e47272ef2204c0b75))
+
+## [27.4.41](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.40...v27.4.41) (2023-10-04)
+
+
+### Bug Fixes
+
+* **lms:** sorting and filtering lms status ([f48862e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f48862efbcb95e92203a200267e1bcc613af4af1))
+* **lms:** sorting and filtering lms status works throughout now ([ae44703](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ae4470333e2b1b5c271b38092210c094822f4a19))
+* **print:** apc ident aliases did not stop at first success ([b7d4f69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b7d4f6913d8b1a70c1b7ef73782cf29861dc11a7))
+
+## [27.4.40](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.39...v27.4.40) (2023-09-26)
+
+## [27.4.39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.38...v27.4.39) (2023-09-26)
+
+
+### Bug Fixes
+
+* **lms:** do not mark lms users with open status as ended ([a848126](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a84812640f02981875275c96e37338de4ab49996))
+* **qualifications:** latest block could ignore itself ([bb708ca](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bb708ca540557b41d33996cfea9a390a457ed855))
+
+## [27.4.38](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.37...v27.4.38) (2023-09-21)
+
+## [27.4.37](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.36...v27.4.37) (2023-09-21)
+
+
+### Bug Fixes
+
+* **lms:** disable workaround for late lms success ([cb9e09d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cb9e09d071d22f41a92ab8140d7aaa643c748373))
+
+## [27.4.36](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.34...v27.4.36) (2023-09-21)
+
+
+### Bug Fixes
+
+* **lms:** treat simultaneous blocks/unblocks correctly ([11752dc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/11752dc5ac96f36ebf9a4cad43fa4e4b55c1b21c))
+
 ## [27.4.35](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.34...t27.4.35) (2023-09-21)

 ## [27.4.34](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.33...t27.4.34) (2023-09-21)
--- a/flake.nix
+++ b/flake.nix
@ -112,8 +112,26 @@

          overlays = [
            (final: prev: let
-              pkgs-recent = import nixpkgs-recent { inherit system; };
-            in {  inherit (pkgs-recent) dockerTools node2nix stack glibcLocalesUtf8 tzdata chromium minio minio-client skopeo; inherit (pkgs-recent.stdenv) fetchurlBoot; })
+                pkgs-recent = import nixpkgs-recent { inherit system; };
+               in {
+                 inherit (pkgs-recent) dockerTools node2nix glibcLocalesUtf8 tzdata chromium minio minio-client skopeo; inherit (pkgs-recent.stdenv) fetchurlBoot;
+                 stack = pkgs.symlinkJoin {
+                  inherit (pkgs-recent.stack) name;
+                  paths = [pkgs-recent.stack];
+                  nativeBuildInputs = [pkgs-recent.makeWrapper];
+
+                  postBuild = ''
+                    wrapProgram $out/bin/stack \
+                      --prefix PATH : "${prev.lib.makeBinPath [pkgs-recent.nix]}" \
+                      --add-flags "\
+                        --nix \
+                        --no-nix-pure \
+                        --nix-shell-file=${./stack.nix} \
+                        --nix-path=nixpkgs=${nixpkgs} \
+                      "
+                  '';
+                };
+               })

            (import ./nix/maildev)
            haskell-nix.overlay
--- a/messages/uniworx/categories/admin/de-de-formal.msg
+++ b/messages/uniworx/categories/admin/de-de-formal.msg
@ -45,7 +45,7 @@ MailTestFormEmail: E-Mail-Adresse
 MailTestFormLanguages: Spracheinstellungen
 MailRerouteTo dev@Address: Alle Emails werden nicht an die eigentlichen Empfänger versendet, sondern umgeleitet zu _{dev}. Druckaufträge werden generiert, aber nicht zum tatsächlichen Druck gesendet.
 TestDownload: Download-Test
-BearerTokenUsageWarning: Mit diesem Interface können quesi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler/einer erfahrenen Entwicklerin über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden!
+BearerTokenUsageWarning: Mit diesem Interface können quasi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler/einer erfahrenen Entwicklerin über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden!
 BearerTokenAuthorityGroups: Token-Authorität (Gruppen)
 BearerTokenAuthorityGroupsTip: Die primären Benutzer:innen aller angegebenen Gruppen müssen Zugriff auf eine Route haben, damit das Token den Zugriff auf diese Route erlaubt.
 BearerTokenAuthorityGroupMissing: Gruppe wird benötigt
--- a/messages/uniworx/categories/qualification/de-de-formal.msg
+++ b/messages/uniworx/categories/qualification/de-de-formal.msg
@ -8,7 +8,7 @@ QualificationDescription: Beschreibung
 QualificationValidIndicator: Gültigkeit
 QualificationValidDuration: Gültigkeitsdauer
 QualificationAuditDuration: Aufbewahrung Audit Log
-QualificationAuditDurationTooltip: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hiweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen.
+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.
 QualificationRefreshWithin: Erneurerungszeitraum
 QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email.
 QualificationRefreshReminder: 2. Erinnerung
@ -121,7 +121,7 @@ LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versende
 LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen
 LmsActRenewNotify: Neue zufällige E‑Learning Passwort zuweisen und Benachrichtigung per Post oder E-Mail versenden
 LmsActReset: E‑Learning Fehlversuche zurücksetzen und entsperren
-LmsActResetInfo: E‑Learning Login und Passwort 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.
+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.
--- a/messages/uniworx/categories/qualification/en-eu.msg
+++ b/messages/uniworx/categories/qualification/en-eu.msg
@ -8,7 +8,7 @@ QualificationDescription: Description
 QualificationValidIndicator: Validity
 QualificationValidDuration: Validity period
 QualificationAuditDuration: Audit log keept
-QualificationAuditDurationTooltip: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier.
+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.
 QualificationRefreshWithin: Refresh within
 QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
 QualificationRefreshReminder: 2. Reminder
@ -121,7 +121,7 @@ LmsActNotify: Resend e‑learning notification by post or email
 LmsActRenewPin: Randomly replace e‑learning password
 LmsActRenewNotify: Randomly replace e‑learning password and re-send notification by post or email
 LmsActReset: Reset and unlock e‑learning
-LmsActResetInfo: E‑learning login and password remain unchanged; a notification is thus not necessary. This is only possible for already failed learners. Note that the reset procedure may take up to 2 hours.
+LmsActResetInfo: E‑learning login, password and progress remain unchanged; a notification is thus not necessary. This is only possible for already failed learners. Note that the reset procedure may take up to 2 hours.
 LmsActResetFeedback n@Int m@Int: For #{n}/#{m} learners all failures were erased, preserving login credentials.
 LmsActRestart: Restart e‑learning
 LmsActRestartWarning: The existing e‑learning will be erased immediately! For drivers with a valid licence, user and password will later be generated anew and a notification will be queued as usual, which may take several hours.
--- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg
+++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg
@ -133,6 +133,8 @@ MenuLmsFake: Testnutzer generieren
 MenuLmsLearners: Export Benutzer E‑Learning
 MenuLmsReport: Ergebnisse E‑Learning

+MenuFirms: Firmen
+
 MenuSap: SAP Schnittstelle

 MenuAvs: AVS Schnittstelle
--- a/messages/uniworx/utils/navigation/menu/en-eu.msg
+++ b/messages/uniworx/utils/navigation/menu/en-eu.msg
@ -134,6 +134,8 @@ MenuLmsFake: Generate Test Users
 MenuLmsLearners: E‑learning Users
 MenuLmsReport: E‑learning Results

+MenuFirms: Companies
+
 MenuSap: SAP Interface 

 MenuAvs: AVS Interface
--- a/messages/uniworx/utils/table_column/de-de-formal.msg
+++ b/messages/uniworx/utils/table_column/de-de-formal.msg
@ -75,8 +75,15 @@ TableExamOfficeLabelStatus: Label-Farbe
 TableExamOfficeLabelPriority: Label-Priorität
 TableQualifications: Qualifikationen
 TableCompany: Firma
+TableCompanyShort: Firmenkürzel
 TableCompanies: Firmen
+TableCompanyNo: Firmennummer
 TableCompanyNos: Firmennummern
+TableCompanyNrUsers: Firmenangehörige
+TableCompanyNrSupers: Ansprechpartner
+TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
+TableCompanyNrRerouteDefault: Standard Umleitungen
+TableCompanyNrRerouteActive: Aktive Umleitungen
 TableSupervisor: Ansprechpartner
 TableCreationTime: Erstellungszeit
 TableJob !ident-ok: Job
--- a/messages/uniworx/utils/table_column/en-eu.msg
+++ b/messages/uniworx/utils/table_column/en-eu.msg
@ -75,8 +75,15 @@ TableExamOfficeLabelStatus: Label colour
 TableExamOfficeLabelPriority: Label priority
 TableQualifications: Qualifications
 TableCompany: Company
+TableCompanyShort: Company shorthand
 TableCompanies: Companies
+TableCompanyNo: Company number
 TableCompanyNos: Company numbers
+TableCompanyNrUsers: Associates
+TableCompanyNrSupers: Supervisors
+TableCompanyNrForeignSupers: External Supervisors
+TableCompanyNrRerouteDefault: Default reroutes
+TableCompanyNrRerouteActive: Active reroutes
 TableSupervisor: Supervisor
 TableCreationTime: Creation
 TableJob !ident-ok: Job
--- a/nix/docker/version.json
+++ b/nix/docker/version.json
@ -1,3 +1,3 @@
 {
-  "version": "27.4.35"
+  "version": "27.4.45"
 }
--- a/package-lock.json
+++ b/package-lock.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "27.4.35",
+  "version": "27.4.45",
  "lockfileVersion": 1,
  "requires": true,
  "dependencies": {
--- a/package.json
+++ b/package.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "27.4.35",
+  "version": "27.4.45",
  "description": "",
  "keywords": [],
  "author": "",
--- a/package.yaml
+++ b/package.yaml
@ -1,5 +1,5 @@
 name: uniworx
-version: 27.4.35
+version: 27.4.45
 dependencies:
  - base
  - yesod
--- a/10
+++ b/10
@ -113,6 +113,10 @@
 /for/#CryptoUUIDUser/user         ForProfileR       GET POST    !supervisor !self
 /for/#CryptoUUIDUser/user/profile ForProfileDataR   GET         !supervisor !self

+/firm                           FirmAllR            GET
+/firm/#CompanyShorthand         FirmR               GET POST
+/firm/#CompanyShorthand/users   FirmUsersR          GET POST
+/firm/#CompanyShorthand/supers  FirmSupersR         GET POST

 /exam-office               ExamOfficeR                         !exam-office:
  /                        EOExamsR            GET POST        !system-exam-office
@ -276,7 +280,7 @@
 /lms/#SchoolId/#QualificationShorthand/edit                 LmsEditR			          GET POST
 -- old V1 LMS Interface
 /lms/#SchoolId/#QualificationShorthand/users                LmsUsersR	              GET
-/lms/#SchoolId/#QualificationShorthand/users/direct         LmsUsersDirectR	        GET       !token -- LMS 
+/lms/#SchoolId/#QualificationShorthand/users/direct         LmsUsersDirectR	        GET       !token -- LMS
 /lms/#SchoolId/#QualificationShorthand/userlist             LmsUserlistR	          GET POST
 /lms/#SchoolId/#QualificationShorthand/userlist/upload      LmsUserlistUploadR	    GET POST  !development
 /lms/#SchoolId/#QualificationShorthand/userlist/direct      LmsUserlistDirectR	        POST  !token -- LMS, also remove JobLmsUserlist constructor
@ -285,11 +289,11 @@
 /lms/#SchoolId/#QualificationShorthand/result/direct        LmsResultDirectR            POST  !token -- LMS, also remove JobLmsResults constructor
 -- new V2 LMS Interface
 /lms/#SchoolId/#QualificationShorthand/learners             LmsLearnersR	          GET
-/lms/#SchoolId/#QualificationShorthand/learners/direct      LmsLearnersDirectR	    GET       !token -- LMS 
+/lms/#SchoolId/#QualificationShorthand/learners/direct      LmsLearnersDirectR	    GET       !token -- LMS
 /lms/#SchoolId/#QualificationShorthand/report               LmsReportR              GET POST
 /lms/#SchoolId/#QualificationShorthand/report/upload        LmsReportUploadR        GET POST  !development
 /lms/#SchoolId/#QualificationShorthand/report/direct        LmsReportDirectR            POST  !token -- LMS
-- other lms routes 
+-- other lms routes
 /lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent      LmsIdentR               GET       -- redirect to LmsR with filter-parameter
 /lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR                GET
 /lmsuser/#CryptoUUIDUser                                    LmsUserAllR             GET
--- a/shell.nix
+++ b/shell.nix
@ -275,7 +275,7 @@ in pkgs.mkShell {
  ++ (with pkgs;
    [ stack nodejs-14_x postgresql_12 openldap exiftool memcached minio minio-client
      gup reuse pre-commit
-      node2nix
+      # node2nix
      # busybox # for print services, but interferes with build commands in develop-shell
      htop
      pdftk # pdftk just for testing pdf-passwords
@ -290,5 +290,5 @@ in pkgs.mkShell {
        ;
      })
    ]
-  ) ++ (with pkgs.haskellPackages; [ yesod-bin hlint cabal-install weeder profiteur ]);
+  ) ++ (with pkgs.haskellPackages; [ yesod-bin hlint cabal-install weeder ]);
 }
--- a/src/Application.hs
+++ b/src/Application.hs
@ -159,6 +159,7 @@ import Handler.SAP
 import Handler.PrintCenter
 import Handler.ApiDocs
 import Handler.Swagger
+import Handler.Firm

 import ServantApi () -- YesodSubDispatch instances
 import Servant.API
--- a/src/Audit/Types.hs
+++ b/src/Audit/Types.hs
@ -212,7 +212,7 @@ data Transaction
    }
  | TransactionQualificationUserEdit  -- Note that a renewal always entails unblocking as well!
    { transactionUser                         :: UserId                 -- qualification holder that is updated
-    , transactionQualificationUser            :: QualificationUserId  -- könnte entfernt werden
+    , transactionQualificationUser            :: QualificationUserId    -- not really necessary, maybe remove?
    , transactionQualification                :: QualificationId    
    , transactionQualificationValidUntil      :: Day
    , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
@ -226,7 +226,12 @@ data Transaction
    { transactionUser               :: UserId                         -- qualification holder that is updated
      -- , transactionQualificationUser  :: QualificationUserId       -- not neccessary due to UniqueQualificationUser
    , transactionQualification      :: QualificationId
-    , transactionQualificationBlock :: QualificationUserBlock         -- TODO -- 
+    , transactionQualificationBlock :: QualificationUserBlock         -- full information about block
+    }
+  | TransactionQualificationUserScheduleRenewal
+    { transactionUser                         :: UserId               -- qualification holder that is updated
+    , transactionQualification                :: QualificationId
+    , transactionQualificationScheduleRenewal :: Maybe Bool           -- TRUE=will be notified upon expiry, FALSE=won't be notified; always JUST, for compatibility with TransactionQualificationUserEdit
    }
  deriving (Eq, Ord, Read, Show, Generic)

--- a/src/Database/Esqueleto/Utils.hs
+++ b/src/Database/Esqueleto/Utils.hs
@ -20,7 +20,7 @@ module Database.Esqueleto.Utils
  , subSelectAnd, subSelectOr
  , mkExactFilter, mkExactFilterWith
  , mkExactFilterLast, mkExactFilterLastWith
-  , mkExactFilterMaybeLast
+  , mkExactFilterMaybeLast, mkExactFilterMaybeLast'
  , mkContainsFilter, mkContainsFilterWith
  , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
  , mkDayFilter, mkDayFilterFrom, mkDayFilterTo
@ -33,6 +33,7 @@ module Database.Esqueleto.Utils
  , selectExists, selectNotExists
  , SqlHashable
  , sha256
+  , isTrue, isFalse
  , maybe, maybe2, maybeEq, guardMaybe, unsafeCoalesce
  , bool
  , max, min
@ -42,9 +43,10 @@ module Database.Esqueleto.Utils
  , (->.), (->>.), (#>>.)
  , fromSqlKey
  , unKey
+  , subSelectCountDistinct
  , selectCountRows, selectCountDistinct
  , selectMaybe
-  , day, day', interval, diffDays, diffTimes
+  , day, day', dayMaybe, interval, diffDays, diffTimes
  , exprLift
  , explicitUnsafeCoerceSqlExprValue
  , module Database.Esqueleto.Utils.TH
@ -313,6 +315,18 @@ mkExactFilterMaybeLast lenslike row criterias
  | Last (Just crit)    <- criterias = lenslike row E.==. E.val crit
  | otherwise   = true

+-- | like `mkExactFilterMaybeLast` but for doubly wrapped Maybes
+mkExactFilterMaybeLast' :: (PersistField a, PersistField b)
+                      => (t -> E.SqlExpr (E.Value (Maybe b)))           -- ^ getter from query ensure entity exists at all
+                      -> (t -> E.SqlExpr (E.Value (Maybe (Maybe a))))   -- ^ getter from query to searched element
+                      -> t                                              -- ^ query row
+                      -> Last (Maybe a)                                 -- ^ needle
+                      -> E.SqlExpr (E.Value Bool)
+mkExactFilterMaybeLast' lensexists lenslike row criterias
+  | Last (Just Nothing) <- criterias = isJust (lensexists row) E.&&. E.isNothing (E.joinV $ lenslike row)
+  | Last (Just crit)    <- criterias = lenslike row E.==. E.val (Just crit)
+  | otherwise   = true
+
 -- | 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)
@ -476,6 +490,12 @@ sha256 :: SqlHashable a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value (Digest S
 sha256 = E.unsafeSqlFunction "digest" . (, E.val "sha256" :: E.SqlExpr (E.Value Text))


+isTrue :: E.SqlExpr (E.Value (Maybe Bool)) -> E.SqlExpr (E.Value Bool)
+isTrue expr = E.unsafeSqlBinOp "IS TRUE" expr $ E.unsafeSqlValue ""
+
+isFalse :: E.SqlExpr (E.Value (Maybe Bool)) -> E.SqlExpr (E.Value Bool)
+isFalse expr = E.unsafeSqlBinOp "IS FALSE" expr $ E.unsafeSqlValue ""
+
 maybe :: (PersistField a, PersistField b)
      => E.SqlExpr (E.Value b)
      -> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b))
@ -608,6 +628,12 @@ unKey :: ( Coercible (Key entity) a
      => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value a)
 unKey = E.veryUnsafeCoerceSqlExprValue

+-- | distinct version of `Database.Esqueleto.subSelectCount`
+subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a)
+subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query)
+  
+-- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
+-- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)

 selectCountRows :: (Num a, PersistField a, MonadIO m) => E.SqlQuery ignored -> E.SqlReadT m a
 selectCountRows q = do
@ -637,6 +663,9 @@ day = E.unsafeSqlCastAs "date"
 day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day)
 day' = E.unsafeSqlCastAs "date"

+dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day))
+dayMaybe = E.unsafeSqlCastAs "date"
+
 interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=.  requires both types to be the same, so we use Day
 -- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example 
 interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@ -123,6 +123,11 @@ breadcrumb ProblemFbutNoR       = i18nCrumb MsgProblemsRWithoutFHeading   $ Just
 breadcrumb ProblemAvsSynchR     = i18nCrumb MsgProblemsAvsSynchHeading    $ Just AdminProblemsR
 breadcrumb ProblemAvsErrorR     = i18nCrumb MsgProblemsAvsErrorHeading    $ Just ProblemAvsSynchR

+breadcrumb FirmAllR         = i18nCrumb MsgMenuFirms            Nothing
+breadcrumb FirmR{}          = i18nCrumb MsgMenuFirms          $ Just FirmAllR
+breadcrumb FirmUsersR{}     = i18nCrumb MsgMenuFirms          $ Just FirmAllR
+breadcrumb FirmSupersR{}    = i18nCrumb MsgMenuFirms          $ Just FirmAllR
+
 breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc              Nothing
 breadcrumb PrintSendR       = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR
 breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload  $ Just PrintCenterR
@ -754,6 +759,18 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
        , navForceActive = False
        }
      }
+  , return NavHeader
+      { navHeaderRole = NavHeaderPrimary
+      , navIcon       = IconCompany
+      , navLink       = NavLink
+        { navLabel       = MsgMenuFirms
+        , navRoute       = FirmAllR
+        , navAccess'     = NavAccessTrue
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
  , return NavHeader
      { navHeaderRole = NavHeaderPrimary
      , navIcon       = IconPrintCenter
@ -2398,6 +2415,16 @@ pageActions ApiDocsR = return
    , navChildren = []
    }
  ]
+pageActions (FirmR fsh) = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = defNavLink MsgTableCompanyNrUsers  $ FirmUsersR fsh
+    , navChildren = []
+    }
+  ]
 pageActions PrintCenterR = do
  openDays <- useRunDB $ Ex.select $ do
    pj <- Ex.from $ Ex.table @PrintJob
--- a/src/Handler/Admin/Avs.hs
+++ b/src/Handler/Admin/Avs.hs
@ -431,8 +431,7 @@ getProblemAvsSynchR = do
          <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld

  now <- liftIO getCurrentTime
-  let nowaday = utctDay now
-      procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
+  let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
      procRes aLic (LicenceTableChangeAvsData       , apids) = do
        oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
        let no_req = Set.size apids
@ -458,7 +457,7 @@ getProblemAvsSynchR = do
          uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
          -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
          void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True Nothing (Left licenceTableChangeFDriveReason) False
-          forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
+          forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId now licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew "Admin Resolution"
          (length uids,) <$> get404 licenceTableChangeFDriveQId
        addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
        redirect ProblemAvsSynchR -- must be outside runDB
@ -556,11 +555,12 @@ mkLicenceTable apidStatus dbtIdent aLic apids = 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)]
-              return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
-            let companies = intersperse (text2markup ", ") $
-                  (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
-                icnSuper = text2markup " " <> icon IconSupervisor
-            pure $ toWgt $ mconcat companies
+              return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
+            let icnSuper  = toWidget $ text2markup " " <> icon IconSupervisor
+                companies = 
+                  (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
+                
+            pure $ intercalate (text2widget "; ") companies
        , sortable (Just "qualification") (i18nCell MsgTableQualifications)          $ \(preview   resultQualification -> q) -> 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
--- a/src/Handler/Admin/Crontab.hs
+++ b/src/Handler/Admin/Crontab.hs
@ -220,5 +220,5 @@ postAdminJobsR = do
  
    getJobName :: Value -> Maybe Text
    getJobName (Object o) 
-      | Just (String s) <- HashMap.lookup "job" o = Just s -- $ kebabToCamel s
+      | Just (String s) <- HashMap.lookup "job" o = Just s --  (kebabToCamel s)
    getJobName _ = Nothing
--- a/src/Handler/Course/ParticipantInvite.hs
+++ b/src/Handler/Course/ParticipantInvite.hs
@ -49,11 +49,19 @@ tutorialTemplateNames Nothing     = ["Vorlage", "Template"]
 tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]]

 tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName
-tutorialDefaultName Nothing     = CI.mk . tshow  -- Don't use user date display setting, so that tutorial default names conform to all users
+tutorialDefaultName Nothing     = formatDayForTutName 
 tutorialDefaultName (Just ttyp) = 
  let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp
  in  (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing

+formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user
+-- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this
+formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow 
+  where 
+    d2u '-' = '_'
+    d2u  c  =  c
+
+
 data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 instance Universe ButtonCourseRegisterMode
--- a/src/Handler/Firm.hs
+++ b/src/Handler/Firm.hs
@ -0,0 +1,779 @@
+-- SPDX-FileCopyrightText: 2023 Steffen Jost <S.Jost@fraport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports #-}      -- TODO: remove me, for debugging only
+{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
+{-# LANGUAGE TypeApplications #-}
+
+module Handler.Firm
+  ( getFirmAllR   , postFirmAllR  
+  , getFirmR      , postFirmR
+  , getFirmUsersR , postFirmUsersR
+  , getFirmSupersR, postFirmSupersR
+  )
+  where
+
+import Import
+
+-- import Jobs
+import Handler.Utils
+
+-- import qualified Data.Set as Set
+-- import qualified Data.Map as Map
+-- import qualified Data.Csv as Csv
+-- import qualified Data.Text as T
+-- import qualified Data.CaseInsensitive as CI
+-- import qualified Data.Conduit.List as C
+-- import Database.Persist.Sql (updateWhereCount)
+import           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
+-- import qualified Database.Esqueleto.Legacy as EL
+-- import qualified Database.Esqueleto.PostgreSQL as E
+import qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils.TH
+
+
+-- avoids repetition of local definitions
+-- single :: (k,a) -> Map k a
+-- single = uncurry Map.singleton
+
+
+getFirmR,  postFirmR :: CompanyShorthand -> Handler Html
+getFirmR = postFirmR
+postFirmR fsh = do
+  let fshId = CompanyKey fsh
+  cusers <- runDB $ do 
+    cusers <- selectList [UserCompanyCompany ==. fshId] []
+    selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName]
+  csuper <- runDB $ do 
+    csuper <- selectList [UserCompanyCompany ==. fshId, UserCompanySupervisor ==. True] []
+    selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName]
+  cactSuper <- runDB $ E.select $ do 
+      (usr :& spr :& scmpy) <- E.from $ 
+                        E.table @User
+          `E.innerJoin` E.table @UserSupervisor
+          `E.on` (\(usr :& spr         ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId)
+          `E.leftJoin`  E.table @UserCompany
+          `E.on` (\(_   :& spr :& scmpy) -> spr E.^. UserSupervisorSupervisor E.=?. scmpy E.?. UserCompanyUser)
+      E.where_ $ (spr E.^. UserSupervisorUser) `E.in_` E.valList (entityKey <$> cusers)
+      E.groupBy (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany)
+      E.orderBy [E.asc $ usr E.^. UserId, E.asc $ usr E.^. UserDisplayName, E.asc $ usr E.^. UserSurname, E.asc $ scmpy E.?. UserCompanyCompany]
+      let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
+      return    (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows')
+  
+  siteLayoutMsg (SomeMessage fsh) $ do 
+    setTitle $ citext2Html fsh
+    [whamlet|      
+      <h3>#{length csuper} Company Default Supervisors (non-foreign only)
+      <ul> 
+        $forall u <- csuper
+          <li>^{linkUserWidget ForProfileDataR u}
+
+      <h3>#{length cactSuper} Active Supervisors for Employees
+      <ul> 
+        $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr) <- cactSuper
+          <li>#{nr} Employees supervised by ^{nameWidget dn sn} 
+            $maybe csh <- mbCsh
+              $if csh /= fshId
+                from foreign company #{unCompanyKey csh}
+              $else 
+                from this company                
+            $nothing
+              having no associated company
+
+      <h3>#{length cusers} Employees 
+      <ul>
+        $forall u <- cusers
+          <li>^{linkUserWidget ForProfileDataR u}
+
+      In the end, this needs to be a dbTable, of course!
+    |]
+
+
+getFirmAllR, postFirmAllR :: Handler Html
+getFirmAllR = postFirmAllR
+postFirmAllR = do
+  uid <- requireAuthId
+  isAdmin <- hasReadAccessTo AdminR
+  firmTable <- runDB $ do 
+    view _2 <$> mkFirmAllTable isAdmin uid -- filter to associated companies for non-admins
+  siteLayoutMsg MsgMenuFirms $ do 
+    setTitleI MsgMenuFirms
+    --     $(widgetFile "firm-all")
+    [whamlet|!!!STUB!!!TO DO!!!        
+        ^{firmTable}
+    |]
+
+
+type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64)
+resultAllCompany                :: Lens' AllCompanyTableData Company
+resultAllCompany                = _dbrOutput . _1 . _entityVal 
+
+resultAllCompanyUsers           :: Lens' AllCompanyTableData Word64
+resultAllCompanyUsers           = _dbrOutput . _2 . _unValue
+
+resultAllCompanySupervisors     :: Lens' AllCompanyTableData Word64
+resultAllCompanySupervisors     = _dbrOutput . _3 . _unValue
+
+resultAllCompanyForeignSupers   :: Lens' AllCompanyTableData Word64
+resultAllCompanyForeignSupers   = _dbrOutput . _4 . _unValue
+
+resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Word64
+resultAllCompanyDefaultReroutes = _dbrOutput . _5 . _unValue
+
+resultAllCompanyActiveReroutes  :: Lens' AllCompanyTableData Word64
+resultAllCompanyActiveReroutes  = _dbrOutput . _6 . _unValue
+
+resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64
+resultAllCompanyActiveReroutes' = _dbrOutput . _7 . _unValue
+
+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.subSelectCount . fromUserCompany Nothing
+
+firmCountSupervisors  :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountSupervisors  = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))      
+-- firmCountSupervisors  :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do 
+--   usrCmpy <- E.from $ E.table @UserCompany
+--   E.where_ $ (usrCmpy E.^. UserCompanyCompany    E.==. cmpy E.^. CompanyId)
+--       E.&&.  (usrCmpy E.^. UserCompanySupervisor E.==. E.true)
+--   return $ usrCmpy E.^. UserCompanyUser
+
+firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute))
+
+-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+-- firmCountForeignSupervisors cmpy = E.coalesceDefault
+--   [E.subSelect $ do
+--     usrSuper <- E.from $ E.table @UserSupervisor  
+--     E.groupBy (usrSuper E.^. UserSupervisorSupervisor)
+--     E.where_ $  E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser)       cmpy)
+--       E.&&.  E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)      
+--     return E.countRows
+--   ] (E.val 0)
+
+firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do 
+    usrSuper <- E.from $ E.table @UserSupervisor    
+    E.where_ $  E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser)       cmpy)
+      E.&&.  E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
+    pure $ usrSuper E.^. UserSupervisorSupervisor
+
+firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do
+    usrSuper <- E.from $ E.table @UserSupervisor    
+    E.where_ $  E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser)       cmpy)
+      E.&&.  usrSuper E.^. UserSupervisorRerouteNotifications
+    pure $ usrSuper E.^. UserSupervisorSupervisor
+
+firmCountActiveReroutes' :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountActiveReroutes' cmpy = E.subSelectCount $ do
+    usrSuper <- E.from $ E.table @UserSupervisor    
+    E.where_ $  E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser)       cmpy)
+      E.&&.  usrSuper E.^. UserSupervisorRerouteNotifications
+
+
+mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget)
+mkFirmAllTable isAdmin uid = do 
+  -- now <- liftIO getCurrentTime
+  let        
+    resultDBTable = DBTable{..}
+      where
+        dbtSQLQuery cmpy = do         
+          unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies
+            usrCmpy <- E.from $ E.table @UserCompany
+            E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
+                E.&&.  usrCmpy E.^. UserCompanyUser E.==. E.val uid
+          return  ( cmpy
+                  , cmpy & firmCountUsers
+                  , cmpy & firmCountSupervisors
+                  , cmpy & firmCountForeignSupervisors
+                  , cmpy & firmCountDefaultReroutes
+                  , cmpy & firmCountActiveReroutes
+                  , cmpy & firmCountActiveReroutes'
+                  )
+        dbtRowKey = (E.^. CompanyId)
+        dbtProj = dbtProjId
+        dbtColonnade = dbColonnade $ mconcat
+          [ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand))
+            sortable (Just "name")        (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> 
+              anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm
+          , sortable (Just "short")       (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> 
+              let fsh = companyShorthand firm 
+              in  anchorCell (FirmR fsh) $ toWgt fsh
+          , sortable (Just "avsnr")       (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> 
+              anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm
+          , sortable (Just "users")         (i18nCell MsgTableCompanyNrUsers)          $ \(view resultAllCompanyUsers           -> nr) -> wgtCell $ word2widget nr
+          , sortable (Just "supervisors")   (i18nCell MsgTableCompanyNrSupers)         $ \(view resultAllCompanySupervisors     -> nr) -> wgtCell $ word2widget nr
+          , sortable (Just "reroute-def")   (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> nr) -> wgtCell $ word2widget nr
+          , sortable (Just "foreigners")    (i18nCell MsgTableCompanyNrForeignSupers)  $ \(view resultAllCompanyForeignSupers   -> nr) -> wgtCell $ word2widget nr
+          , sortable (Just "reroute-act")   (i18nCell MsgTableCompanyNrRerouteActive)  $ \(view resultAllCompanyActiveReroutes  -> nr) -> wgtCell $ word2widget nr
+          , sortable (Just "reroute-all")   (i18nCell MsgTableCompanyNrRerouteActive)  $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr
+          ] 
+        dbtSorting = mconcat
+          [ singletonMap "name"         $ SortColumn (E.^. CompanyName)
+          , singletonMap "short"        $ SortColumn (E.^. CompanyShorthand)
+          , singletonMap "avsnr"        $ SortColumn (E.^. CompanyAvsId)
+          , singletonMap "users"        $ SortColumn firmCountUsers
+          , singletonMap "supervisors"  $ SortColumn firmCountSupervisors
+          , singletonMap "reroute-def"  $ SortColumn firmCountDefaultReroutes
+          , singletonMap "foreigners"   $ SortColumn firmCountForeignSupervisors
+          , singletonMap "reroute-act"  $ SortColumn firmCountActiveReroutes
+          , singletonMap "reroute-all"  $ SortColumn firmCountActiveReroutes'
+          ]
+        dbtFilter = mconcat
+          [            
+          ]
+        dbtFilterUI = mconcat
+          [           
+          ]
+        dbtStyle =  def -- { dbsFilterLayout = defaultDBSFilterLayout }
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "firm"        
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
+        dbtExtraReps = []
+
+    resultDBTableValidator = def
+      -- & defaultSorting  [SortAscBy "school", SortAscBy "qshort"]
+  dbTable resultDBTableValidator resultDBTable
+
+
+
+-- -- getQualificationEditR,  postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html
+-- -- getQualificationEditR = postQualificationEditR 
+-- -- postQualificationEditR = error "TODO"
+
+getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
+getFirmUsersR  = postFirmUsersR
+postFirmUsersR fsh = do 
+  let _fshId = CompanyKey fsh
+  siteLayout (citext2widget fsh) $ do 
+    setTitle $ citext2Html fsh
+    [whamlet|!!!STUB!!!TO DO!!!|]
+
+getFirmSupersR, postFirmSupersR :: CompanyShorthand ->  Handler Html
+getFirmSupersR = postFirmSupersR
+postFirmSupersR fsh = do 
+  let _fshId = CompanyKey fsh
+  siteLayout (citext2widget fsh) $ do 
+    setTitle $ citext2Html fsh
+    [whamlet|!!!STUB!!!TO DO!!!|]
+
+
+-- data QualificationTableCsv = QualificationTableCsv   -- Q..T..C.. -> qtc..
+--   { qtcDisplayName    :: UserDisplayName
+--   , qtcEmail          :: UserEmail
+--   , qtcCompany        :: Maybe Text
+--   , qtcCompanyNumbers :: CsvSemicolonList Int
+--   , qtcValidUntil     :: Day
+--   , qtcLastRefresh    :: Day
+--   , qtcBlockStatus    :: Maybe Bool
+--   , qtcBlockFrom      :: Maybe UTCTime  
+--   , qtcScheduleRenewal:: Bool
+--   , qtcLmsStatusTxt   :: Maybe Text
+--   , qtcLmsStatusDay   :: Maybe UTCTime
+--   }
+--   deriving Generic
+-- makeLenses_ ''QualificationTableCsv
+
+-- qtcExample :: QualificationTableCsv
+-- qtcExample = QualificationTableCsv
+--     { qtcDisplayName    = "Max Mustermann"
+--     , qtcEmail          = "m.mustermann@example.com"
+--     , qtcCompany        = Just "Example Brothers LLC, SecondaryJobs Inc"
+--     , qtcCompanyNumbers = CsvSemicolonList [27,69]
+--     , qtcValidUntil     = compDay
+--     , qtcLastRefresh    = compDay
+--     , qtcBlockStatus    = Nothing
+--     , qtcBlockFrom      = Nothing    
+--     , qtcScheduleRenewal= True
+--     , qtcLmsStatusTxt   = Just "Success"
+--     , qtcLmsStatusDay   = Just compTime
+--     }
+--   where
+--     compTime :: UTCTime
+--     compTime = $compileTime
+--     compDay :: Day
+--     compDay = utctDay compTime
+
+-- qtcOptions :: Csv.Options
+-- qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
+--   where
+--     renameLtc "qtcDisplayName" = "licensee"
+--     renameLtc other = replaceLtc $ camelToPathPiece' 1 other
+--     replaceLtc ('l':'m':'s':'-':t) = prefixLms t
+--     replaceLtc other = other
+--     prefixLms = ("elearn-" <>)
+
+-- instance Csv.ToNamedRecord QualificationTableCsv where
+--   toNamedRecord = Csv.genericToNamedRecord qtcOptions
+
+-- instance Csv.DefaultOrdered QualificationTableCsv where
+--   headerOrder = Csv.genericHeaderOrder qtcOptions
+
+-- instance CsvColumnsExplained QualificationTableCsv where
+--   csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
+--     [ ('qtcDisplayName    , SomeMessage MsgLmsUser)
+--     , ('qtcEmail          , SomeMessage MsgTableLmsEmail)
+--     , ('qtcCompany        , SomeMessage MsgTableCompanies)
+--     , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
+--     , ('qtcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
+--     , ('qtcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
+--     , ('qtcBlockStatus    , SomeMessage MsgInfoQualificationBlockStatus)
+--     , ('qtcBlockFrom      , SomeMessage MsgInfoQualificationBlockFrom)
+--     , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
+--     , ('qtcLmsStatusTxt   , SomeMessage MsgTableLmsStatus)
+--     , ('qtcLmsStatusDay   , SomeMessage MsgTableLmsStatusDay)    
+--     ]
+
+
+-- type QualificationTableExpr = (           E.SqlExpr (Entity QualificationUser)
+--                       `E.InnerJoin`       E.SqlExpr (Entity User)
+--                     ) `E.LeftOuterJoin`   E.SqlExpr (Maybe (Entity LmsUser))
+--                       `E.LeftOuterJoin`   E.SqlExpr (Maybe (Entity QualificationUserBlock))
+
+-- queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser)
+-- queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
+
+-- queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User)
+-- queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
+
+-- queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
+-- queryLmsUser = $(sqlLOJproj 3 2)
+
+-- queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
+-- queryQualBlock = $(sqlLOJproj 3 3)
+
+-- type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany])
+
+-- resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
+-- resultQualUser = _dbrOutput . _1
+
+-- resultUser :: Lens' QualificationTableData (Entity User)
+-- resultUser = _dbrOutput . _2
+
+-- resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser)
+-- resultLmsUser = _dbrOutput . _3 . _Just
+
+-- resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
+-- resultQualBlock = _dbrOutput . _4 . _Just
+
+-- resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
+-- resultCompanyUser = _dbrOutput . _5
+
+
+-- instance HasEntity QualificationTableData User where
+--   hasEntity = resultUser
+
+-- instance HasUser QualificationTableData where
+--   hasUser = resultUser . _entityVal
+
+-- instance HasEntity QualificationTableData QualificationUser where
+--   hasEntity = resultQualUser
+
+-- instance HasQualificationUser QualificationTableData where
+--   hasQualificationUser = resultQualUser . _entityVal
+
+-- -- instance HasEntity QualificationUserBlock where
+-- --   hasQualificationUserBlock = resultQualBlock
+
+
+-- data QualificationTableAction 
+--   = QualificationActExpire 
+--   | QualificationActUnexpire
+--   | QualificationActBlockSupervisor
+--   | QualificationActBlock
+--   | QualificationActUnblock
+--   | QualificationActRenew
+--   | QualificationActGrant
+--   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)  
+
+-- instance Universe QualificationTableAction
+-- instance Finite QualificationTableAction
+-- nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
+-- embedRenderMessage ''UniWorX ''QualificationTableAction id
+
+-- {-
+-- isAdminAct :: QualificationTableAction -> Bool
+-- isAdminAct QualificationActExpire           = False
+-- isAdminAct QualificationActUnexpire         = False
+-- isAdminAct QualificationActBlockSupervisor  = False
+-- isAdminAct _ = True
+-- -}
+
+-- data QualificationTableActionData 
+--   = QualificationActExpireData 
+--   | QualificationActUnexpireData  
+--   | QualificationActBlockSupervisorData
+--   | QualificationActBlockData           { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
+--   | QualificationActUnblockData         { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
+--   | QualificationActRenewData
+--   | QualificationActGrantData           { qualTableActGrantUntil  :: Day }   
+--   deriving (Eq, Ord, Show, Generic)  
+
+-- isExpiryAct :: QualificationTableActionData -> Bool
+-- isExpiryAct QualificationActExpireData    = True
+-- isExpiryAct QualificationActUnexpireData  = True
+-- isExpiryAct _ = False
+
+-- isBlockAct :: QualificationTableActionData -> Bool
+-- isBlockAct QualificationActBlockSupervisorData  = True
+-- isBlockAct QualificationActBlockData{}          = True
+-- isBlockAct QualificationActUnblockData{}        = True
+-- isBlockAct _ = False
+
+-- blockActRemoveSupervisors :: QualificationTableActionData -> Bool
+-- blockActRemoveSupervisors QualificationActBlockSupervisorData  = True
+-- blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res
+-- blockActRemoveSupervisors _ = False
+
+-- -- qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
+-- --   -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
+-- --                 , E.SqlExpr (Entity User)
+-- --                 , E.SqlExpr (Maybe (Entity LmsUser))
+-- --                 )
+-- -- qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUse) = do
+-- --     E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
+-- --             E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause, which does not work
+-- --     E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
+-- --     E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
+-- --     return (qualUser, user, lmsUser)
+
+-- qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
+--   -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
+--                 , E.SqlExpr (Entity User)
+--                 , E.SqlExpr (Maybe (Entity LmsUser))
+--                 , E.SqlExpr (Maybe (Entity QualificationUserBlock))
+--                 )
+-- qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
+--   -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
+--   -- 
+--     E.on $  qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
+--       E.&&. qualBlock `isLatestBlockBefore` E.val now
+--     E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
+--             E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause, which does not work
+--     E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
+--     E.where_ $    fltr qualUser 
+--             E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)            
+--     return (qualUser, user, lmsUser, qualBlock)
+
+
+-- mkQualificationTable ::
+--               ( Functor h, ToSortable h
+--               , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols
+--               )
+--            => Bool
+--            -> Entity Qualification
+--            -> Map QualificationTableAction (AForm Handler QualificationTableActionData)           
+--            -> (Map CompanyId Company -> cols)
+--            -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
+--            -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
+-- mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
+--   svs <- getSupervisees
+--   now <- liftIO getCurrentTime  
+--   -- lookup all companies   
+--   cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do 
+--     cmps <- selectList [] [] -- [Asc CompanyShorthand]
+--     return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
+--   let
+--     nowaday = utctDay now
+--     mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
+--     csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
+--     dbtIdent :: Text
+--     dbtIdent = "qualification"
+--     fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `E.in_` E.vals svs
+--     dbtSQLQuery = qualificationTableQuery now qid fltrSvs
+--     dbtRowKey = queryUser >>> (E.^. UserId)
+--     dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
+--       -- cmps <- 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 (entityKey usr)
+--       --   E.orderBy [E.asc (comp E.^. CompanyName)]
+--       --   return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
+--       cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
+--       return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr)
+--     dbtColonnade = cols cmpMap
+--     dbtSorting = mconcat
+--       [ single $ sortUserNameLink   queryUser
+--       , single $ sortUserEmail      queryUser
+--       , single $ sortUserMatriclenr queryUser
+--       , single ("first-held"    , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
+--       , single ("last-refresh"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
+--       , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
+--       , single ("valid-until"   , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
+--       , single ("blocked"       , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
+--       , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
+--                                                                            , E.joinV (queryLmsUser row E.?. LmsUserNotified)
+--                                                                            ,          queryLmsUser row E.?. LmsUserStarted])
+--       , single ("schedule-renew", SortColumnNullsInv  $ queryQualUser  >>> (E.^. QualificationUserScheduleRenewal))
+--       , single ("user-company"  , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
+--                 E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+--                 E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
+--                 E.orderBy [E.asc (comp E.^. CompanyName)]
+--                 return (comp E.^. CompanyName)
+--               )
+--       -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now)
+--       ]
+--     dbtFilter = mconcat
+--       [ single $ fltrUserNameEmail   queryUser
+--       , single ("avs-number"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
+--               E.from $ \usrAvs -> -- do 
+--                 E.where_ $ usrAvs E.^. UserAvsUser      E.==. queryUser row E.^. UserId
+--                     E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
+--                           (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
+--       , single ("avs-card"  , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
+--             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
+--         )
+--       , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
+--               E.from $ \(usrComp `E.InnerJoin` comp) -> do 
+--                 let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
+--                                 (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
+--                     testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
+--                     testcrit = maybe testname testnumber $ readMay $ CI.original criterion
+--                 E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+--                 E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
+--         )                                  
+--       , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
+--       , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
+--           if | Just renewal <- mbRenewal
+--              , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
+--                                           E.&&.  quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
+--              | otherwise -> E.true
+--         )
+--       , single ("tobe-notified", FilterColumn $ \row criterion ->
+--           if  | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row)
+--               | otherwise -> E.true
+--         )
+--       , single ("status"  , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus))
+--       ]
+--     dbtFilterUI mPrev = mconcat
+--       [ 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)
+--       , prismAForm (singletonFilter "avs-number" )                              mPrev $ aopt textField (fslI MsgAvsPersonNo)            
+--       , prismAForm (singletonFilter "validity"         . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
+--       , if isNothing mbRenewal then mempty
+--         else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
+--       , prismAForm (singletonFilter "tobe-notified"    . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue)
+--       , prismAForm (singletonFilter "status"           . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
+--       ]
+--     dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
+--     dbtCsvEncode = Just DBTCsvEncode
+--       { dbtCsvExportForm   = pure ()
+--       , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
+--       , dbtCsvName         = csvName
+--       , dbtCsvSheetName    = csvName
+--       , dbtCsvNoExportData = Just id
+--       , dbtCsvHeader       = const $ return $ Csv.headerOrder qtcExample
+--       , dbtCsvExampleData  = Just [qtcExample]
+--       }
+--       where
+--         doEncode' :: QualificationTableData -> QualificationTableCsv
+--         doEncode' = QualificationTableCsv
+--           <$>  view    (resultUser     . _entityVal . _userDisplayName)
+--           <*>  view    (resultUser     . _entityVal . _userDisplayEmail)
+--           <*> (view     resultCompanyUser >>= getCompanies)
+--           <*> (view     resultCompanyUser >>= getCompanyNos)
+--           <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
+--           <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)                  
+--           <*>  preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
+--           <*>  preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)          
+--           <*>  view    (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
+--           <*>  getStatusPlusTxt
+--           <*>  getStatusPlusDay
+--         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))
+
+--         getStatusPlusTxt = 
+--           (join . preview (resultLmsUser  . _entityVal . _lmsUserStatus)) >>= \case 
+--             Just LmsBlocked{} -> return $ Just "Failed"
+--             Just LmsExpired{} -> return $ Just "Expired"
+--             Just LmsSuccess{} -> return $ Just "Success"
+--             Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
+--               preview (resultLmsUser  . _entityVal . _lmsUserStarted)
+--         getStatusPlusDay = 
+--           (join . preview (resultLmsUser  . _entityVal . _lmsUserStatusDay)) >>= \case 
+--             lsd@(Just _) -> return lsd
+--             Nothing -> preview (resultLmsUser  . _entityVal . _lmsUserStarted)
+          
+--     dbtCsvDecode = Nothing
+--     dbtExtraReps = []    
+--     dbtParams = DBParamsForm
+--       { dbParamsFormMethod = POST
+--       , dbParamsFormAction = Nothing
+--       , dbParamsFormAttrs  = []
+--       , dbParamsFormSubmit = FormSubmit
+--       , dbParamsFormAdditional
+--           = renderAForm FormStandard
+--                 $  (, mempty) . First . Just
+--               <$> multiActionA acts (fslI MsgTableAction) Nothing
+--       , dbParamsFormEvaluate = liftHandler . runFormPost
+--       , dbParamsFormResult   = id
+--       , dbParamsFormIdent    = def
+--       }
+
+--     postprocess :: FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)
+--                 -> FormResult (      QualificationTableActionData, Set UserId)
+--     postprocess inp = do
+--         (First (Just act), usrMap) <- inp
+--         let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
+--         return (act, usrSet)
+
+--     -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableActionData))
+--     -- resultDBTableValidator = def
+--       -- & defaultSorting [SortAscBy csvLmsIdent]
+--   over _1 postprocess <$> dbTable psValidator DBTable{..}
+
+-- getQualificationR,  postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
+-- getQualificationR = postQualificationR
+-- postQualificationR sid qsh = do  
+--   isAdmin <- hasReadAccessTo AdminR
+--   msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning
+--   msgUnexpire     <- messageIconI Info    IconWarning MsgQualificationActUnexpireWarning
+--   now <- liftIO getCurrentTime
+--   let nowaday = utctDay now
+--   ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
+--     qent@Entity{
+--         entityKey=qid
+--       , entityVal=Qualification{
+--           qualificationAuditDuration=auditMonths
+--         , qualificationValidDuration=validMonths
+--       }} <- getBy404 $ SchoolQualificationShort sid qsh
+
+--     -- Block copied to Handler/Qualifications TODO: refactor
+--     let getBlockReasons unblk = E.select $ do 
+--           (quser :& qblock) <- E.from $ E.table @QualificationUser 
+--             `E.innerJoin` E.table @QualificationUserBlock
+--             `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser)
+--           E.where_ $     quser  E.^. QualificationUserQualification E.==. E.val qid
+--             E.&&. unblk (qblock E.^. QualificationUserBlockUnblock)
+--           E.groupBy     (qblock E.^. QualificationUserBlockReason)        
+--           let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
+--           E.orderBy [E.desc countRows']
+--           E.limit 7
+--           pure (qblock E.^. QualificationUserBlockReason)
+--         mkOption :: E.Value Text -> Option Text
+--         mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
+--         suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
+--         suggestionsBlock   = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
+--         suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
+--         dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
+--         acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
+--         acts = mconcat $
+--           [ singletonMap QualificationActExpire   $ pure QualificationActExpireData
+--           , singletonMap QualificationActUnexpire $      QualificationActUnexpireData 
+--               <$ aformMessage msgUnexpire        
+--           ] ++ bool 
+--           -- nonAdmin actions, ie. Supervisor
+--           [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] 
+--           -- Admin-only actions
+--           [ singletonMap QualificationActUnblock         $      QualificationActUnblockData
+--               <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock)  (fslI MsgQualificationGrantReason)             Nothing
+--               <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant)      (fslI MsgQualificationBlockNotify)            (Just False)
+--           , singletonMap QualificationActBlock           $      QualificationActBlockData 
+--               <$> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationBlockReason)             Nothing
+--               <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant)      (fslI MsgQualificationBlockNotify)            (Just False)
+--               <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant)      (fslI MsgQualificationBlockRemoveSupervisor)  (Just False)
+--           , singletonMap QualificationActRenew           $ pure QualificationActRenewData
+--           , singletonMap QualificationActGrant           $      QualificationActGrantData 
+--                 <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
+--                 <*  aformMessage msgGrantWarning
+--           ] isAdmin
+--         linkLmsUser     = toMaybe isAdmin (LmsUserR sid qsh)
+--         linkUserName    = bool ForProfileR ForProfileDataR isAdmin        
+--         colChoices cmpMap = mconcat
+--           [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
+--           , colUserNameModalHdr MsgLmsUser linkUserName
+--           , colUserEmail          
+--           , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
+--               let icnSuper = text2markup " " <> icon IconSupervisor
+--                   cs =  [ (cmpName, cmpSpr) 
+--                         | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps                        
+--                         , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
+--                         ]
+--                   companies = intercalate (text2markup ", ") $
+--                     (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
+--               in wgtCell companies
+--           , guardMonoid isAdmin colUserMatriclenr
+--           -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
+--           , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $    \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
+--           , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$    \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d          
+--           , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)  (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
+--           , sortable (Just "blocked")       (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> 
+--               qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row
+--           , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
+--                                                                                     )     $ \(   view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
+--           , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
+--                                                                                           $ \(preview $ resultLmsUser  . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu
+--           , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d
+--           ]
+--         psValidator = def & defaultSorting [SortDescBy "last-refresh"]
+--     tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
+--     return (tbl, qent)
+  
+--   formResult lmsRes $ \case
+--     (QualificationActRenewData, selectedUsers) | isAdmin -> do
+--       noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers      
+--       addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
+--       reloadKeepGetParams $ QualificationR sid qsh
+--     (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do      
+--       runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
+--       addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
+--       reloadKeepGetParams $ QualificationR sid qsh
+--     (action, selectedUsers) | isExpiryAct action -> do
+--       let isUnexpire = action == QualificationActUnexpireData
+--       upd <- runDB $ updateWhereCount
+--               [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
+--               [QualificationUserScheduleRenewal =. isUnexpire]
+--       let msgKind = if upd > 0  then Success else Warning
+--           msgVal  = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
+--       addMessageI msgKind msgVal
+--       reloadKeepGetParams $ QualificationR sid qsh
+--     (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData)  -> do      
+--       let selUserIds = Set.toList selectedUsers
+--           (unblock, reason) = case action of 
+--               QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)              
+--               QualificationActBlockData{..}       -> (False, Left qualTableActBlockReason)
+--               QualificationActUnblockData{..}     -> (True , Left qualTableActBlockReason)
+--               _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
+--           notify = case action of 
+--               QualificationActBlockData{qualTableActNotify} -> qualTableActNotify
+--               _ -> False
+          
+--       oks <- runDB $ do 
+--         when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
+--         qualificationUserBlocking qid selUserIds unblock Nothing reason notify
+--       let nrq = length selectedUsers
+--           warnLevel = if
+--             | oks < 0    -> Error
+--             | oks == nrq -> Success
+--             | otherwise  -> Warning
+--           fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock
+--       addMessageI warnLevel $ fbmsg qsh oks nrq
+--       reloadKeepGetParams $ QualificationR sid qsh
+--     _ -> addMessageI Error MsgInvalidFormAction
+
+--   let heading = citext2widget $ qualificationName quali
+--   siteLayout heading $ do
+--     setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
+--     $(widgetFile "qualification")
--- a/src/Handler/LMS.hs
+++ b/src/Handler/LMS.hs
@ -3,7 +3,6 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later

 {-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
-{-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only
 {-# LANGUAGE TypeApplications #-}

 module Handler.LMS
@ -42,7 +41,7 @@ import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.Csv as Csv
 import qualified Data.Text as T
-import qualified Data.CaseInsensitive as CI
+-- import qualified Data.CaseInsensitive as CI
 import qualified Data.Conduit.List as C
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
@ -104,9 +103,10 @@ postLmsAllR = do
              , formEncoding = btnEnctype
              , formSubmit   = FormNoSubmit
              }
-  
+
+  LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
  lmsTable <- runDB $ do
-    view _2 <$> mkLmsAllTable isAdmin
+    view _2 <$> mkLmsAllTable isAdmin lmsDeletionDays
  siteLayoutMsg MsgMenuLms $ do
    setTitleI   MsgMenuLms
    $(widgetFile "lms-all")
@ -122,8 +122,8 @@ resultAllQualificationTotal  :: Lens' AllQualificationTableData Word64
 resultAllQualificationTotal  = _dbrOutput . _3 . _unValue

  
-mkLmsAllTable :: Bool -> DB (Any, Widget)
-mkLmsAllTable isAdmin = do
+mkLmsAllTable :: Bool -> Int -> DB (Any, Widget)
+mkLmsAllTable isAdmin lmsDeletionDays = do
  svs <- getSupervisees   
  let
    resultDBTable = DBTable{..}
@ -160,7 +160,7 @@ mkLmsAllTable isAdmin = do
          -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin)   $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
          , sortable Nothing (i18nCell MsgQualificationRefreshReminder  & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshReminder)
-          , sortable Nothing (i18nCell MsgQualificationAuditDuration    & cellTooltips [SomeMessage MsgQualificationAuditDurationTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
+          , sortable Nothing (i18nCell MsgQualificationAuditDuration    & cellTooltips [SomeMessage (MsgQualificationAuditDurationTooltip lmsDeletionDays), SomeMessage MsgTableDiffDaysTooltip]) $
              foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
          , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
                                                                        $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
@ -423,7 +423,7 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
                    E.where_ $ E.isJust (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!
-                    pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated     ) pjOrder, -- return two aggregates only works with select, the restricted typr 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                                                        
    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)

@ -444,7 +444,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
    cmps <- selectList [] [] -- [Asc CompanyShorthand]
    return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
  let            
-    csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
+    csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
    dbtIdent :: Text
    dbtIdent = "lms"
    dbtSQLQuery = lmsTableQuery now qid
@ -465,7 +465,11 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
      , single ("schedule-renew", SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserScheduleRenewal))
      , single ("ident"     , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserIdent))
      , single ("pin"       , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserPin))
-      , single ("status"    , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus))
+      -- , single ("status"    , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay))
+      , single ("status"    , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay
+                                                                              , queryLmsUser row E.^. LmsUserNotified
+                                                                              ](queryLmsUser row E.^. LmsUserStarted))
+
      , single ("started"   , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserStarted))
      , single ("datepin"   , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserDatePin))
      , single ("received"  , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserReceived))
@ -501,7 +505,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
                let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
                                (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
                    testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
-                    testcrit = maybe testname testnumber $ readMay $ CI.original criterion
+                    testcrit = maybe testname testnumber $ readMay $ ciOriginal criterion
                E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
        )        
@ -632,14 +636,11 @@ postLmsR sid qsh = do
          , colUserNameModalHdr MsgLmsUser AdminUserR
          , colUserEmail
          , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
-              let icnSuper = text2markup " " <> icon IconSupervisor
-                  cs =  [ (cmpName, cmpSpr) 
+              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap                        
                        ]
-                  companies = intercalate (text2markup ", ") $
-                    (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
-              in wgtCell companies            
+              in intercalate spacerCell cs
          , colUserMatriclenr
          -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)          
          , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
@ -734,10 +735,10 @@ postLmsR sid qsh = do
            , QualificationUserUser <-. usersList            
            , QualificationUserValidUntil <. cutoff
            ] []          
-          forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing
+          forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"

        fromIntegral <$> (if isReset
-            then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective
+            then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective
                                    ++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired]))     [LmsUserResetTries =. True]
            else deleteWhereCount  [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
          )
@ -786,6 +787,7 @@ postLmsR sid qsh = do
  let heading = citext2widget $ "LMS " <> qualificationName quali
  siteLayout heading $ do
    setTitle $ toHtml $ "LMS " <> unSchoolKey sid <> "-" <> qsh
+    LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
    $(widgetFile "lms")

 -- redirect to a specific lms user
--- a/src/Handler/LMS/Learners.hs
+++ b/src/Handler/LMS/Learners.hs
@ -90,9 +90,8 @@ instance CsvColumnsExplained LmsUserTableCsv where



-mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
-mkUserTable _sid qsh qid = do
-  cutoff <- liftHandler lmsDeletionDate
+mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget)
+mkUserTable _sid qsh qid cutoff = do
  dbtCsvName <- csvFilenameLmsUser qsh  
  let dbtCsvSheetName = dbtCsvName
  let
@ -158,25 +157,31 @@ mkUserTable _sid qsh qid = do
      & defaultSorting [SortAscBy csvLmsIdent]
  dbTable userDBTableValidator userDBTable

+getQidCutoff ::  SchoolId -> QualificationShorthand -> DB (QualificationId, UTCTime)
+getQidCutoff sid qsh = do
+  Entity{entityKey = qid, entityVal = Qualification{qualificationAuditDuration=auditDur}} <- getBy404 $ SchoolQualificationShort sid qsh
+  cutoff <- liftHandler $ lmsDeletionDate auditDur
+  return (qid, cutoff)
+
 getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
 getLmsLearnersR sid qsh = do
  lmsTable <- runDB $ do
-    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-    view _2 <$> mkUserTable sid qsh qid
+    (qid, cutoff) <- getQidCutoff sid qsh    
+    view _2 <$> mkUserTable sid qsh qid cutoff
  siteLayoutMsg MsgMenuLmsLearners $ do
    setTitleI MsgMenuLmsLearners
    lmsTable

 getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
 getLmsLearnersDirectR sid qsh = do
-  $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
-  cutoff <- lmsDeletionDate
-  lms_users <- runDB $ do
-    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
-    selectList [ LmsUserQualification ==. qid
-               , LmsUserEnded ==. Nothing
-               -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
-               ] [Asc LmsUserStarted, Asc LmsUserIdent]    
+  $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid  
+  (lms_users,cutoff) <- runDB $ do
+    (qid, cutoff) <- getQidCutoff sid qsh    
+    lms_users <- selectList [ LmsUserQualification ==. qid
+                            , LmsUserEnded ==. Nothing
+                            -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
+                            ] [Asc LmsUserStarted, Asc LmsUserIdent]    
+    return (lms_users, cutoff)

    {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
      Ex.select $ do
@ -202,12 +207,12 @@ getLmsLearnersDirectR sid qsh = do
                    , csvUseCrLf        = lmsDownloadCrLf
                    }
      csvOpts = def { csvFormat = fmtOpts }
-  csvSheetName <- csvFilenameLmsUser "t" -- DEBUG UNDO ME BEFORE PRODUCTION qsh
+  csvSheetName <- csvFilenameLmsUser qsh
  let nr  = length lms_users
-      msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"  
+      msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"  
  $logInfoS "LMS" msg
  addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered  

 -- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
+-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
--- a/src/Handler/LMS/Users.hs
+++ b/src/Handler/LMS/Users.hs
@ -83,7 +83,7 @@ instance CsvColumnsExplained LmsUserTableCsv where

 mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
 mkUserTable _sid qsh qid = do
-  cutoff <- liftHandler lmsDeletionDate
+  cutoff <- liftHandler $ lmsDeletionDate Nothing
  dbtCsvName <- csvFilenameLmsUser qsh  
  let dbtCsvSheetName = dbtCsvName
  let
@ -154,7 +154,7 @@ getLmsUsersR sid qsh = do
 getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
 getLmsUsersDirectR sid qsh = do
  $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
-  cutoff <- lmsDeletionDate
+  cutoff <- lmsDeletionDate Nothing
  lms_users <- runDB $ do
    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
    selectList [ LmsUserQualification ==. qid
--- a/src/Handler/Qualification.hs
+++ b/src/Handler/Qualification.hs
@ -30,7 +30,7 @@ import Database.Persist.Sql (updateWhereCount)
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
 import qualified Database.Esqueleto.Legacy as E
-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

@ -328,17 +328,17 @@ blockActRemoveSupervisors _ = False
 --     E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
 --     return (qualUser, user, lmsUser)

-qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
+qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
  -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
                , E.SqlExpr (Entity User)
                , E.SqlExpr (Maybe (Entity LmsUser))
                , E.SqlExpr (Maybe (Entity QualificationUserBlock))
                )
-qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
+qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
  -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
  -- 
    E.on $  qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
-      E.&&. qualBlock `isLatestBlockBefore` E.now_
+      E.&&. qualBlock `isLatestBlockBefore` E.val now
    E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
            E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause, which does not work
    E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
@ -371,7 +371,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
    dbtIdent :: Text
    dbtIdent = "qualification"
    fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
-    dbtSQLQuery = qualificationTableQuery qid fltrSvs
+    dbtSQLQuery = qualificationTableQuery now qid fltrSvs
    dbtRowKey = queryUser >>> (E.^. UserId)
    dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
      -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
@ -391,9 +391,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
      , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
      , single ("valid-until"   , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
      , single ("blocked"       , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
-      , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
-                                                                  , queryLmsUser row E.?. LmsUserStarted])
-      , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
+      , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
+                                                                           , E.joinV (queryLmsUser row E.?. LmsUserNotified)
+                                                                           ,          queryLmsUser row E.?. LmsUserStarted])
+      , single ("schedule-renew", SortColumnNullsInv  $ queryQualUser  >>> (E.^. QualificationUserScheduleRenewal))
      , single ("user-company"  , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
                E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
@ -436,21 +437,23 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
                                          E.&&.  quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
             | otherwise -> E.true
        )
-      , single ("tobe-notified", FilterColumn $ \(queryQualUser -> quser) criterion ->
-          if  | Just True <- getLast criterion -> quser `quserToNotify` now          
+      , single ("tobe-notified", FilterColumn $ \row criterion ->
+          if  | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row)
              | otherwise -> E.true
        )
+      , single ("status"  , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus))
      ]
    dbtFilterUI mPrev = mconcat
      [ 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)
-      , prismAForm (singletonFilter "avs-number" )      mPrev $ aopt textField (fslI MsgAvsPersonNo)            
-      , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
+      , 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)
+      , prismAForm (singletonFilter "avs-number" )                              mPrev $ aopt textField (fslI MsgAvsPersonNo)            
+      , prismAForm (singletonFilter "validity"         . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
      , if isNothing mbRenewal then mempty
        else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
-      , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue)
+      , prismAForm (singletonFilter "tobe-notified"    . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue)
+      , prismAForm (singletonFilter "status"           . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
      ]
    dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
    dbtCsvEncode = Just DBTCsvEncode
@ -583,14 +586,11 @@ postQualificationR sid qsh = do
          , colUserNameModalHdr MsgLmsUser linkUserName
          , colUserEmail          
          , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
-              let icnSuper = text2markup " " <> icon IconSupervisor
-                  cs =  [ (cmpName, cmpSpr) 
-                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps                        
-                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
+              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
+                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
+                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap                        
                        ]
-                  companies = intercalate (text2markup ", ") $
-                    (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
-              in wgtCell companies
+              in intercalate spacerCell cs
          , guardMonoid isAdmin colUserMatriclenr
          -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
          , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $    \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
@ -614,14 +614,20 @@ postQualificationR sid qsh = do
      addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
      reloadKeepGetParams $ QualificationR sid qsh
    (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do      
-      runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
+      runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
      addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
      reloadKeepGetParams $ QualificationR sid qsh
-    (action, selectedUsers) | isExpiryAct action -> do
+    (action, selectedUsers) | isExpiryAct action -> do      
      let isUnexpire = action == QualificationActUnexpireData
-      upd <- runDB $ updateWhereCount
-              [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
-              [QualificationUserScheduleRenewal =. isUnexpire]
+      upd <- runDB $ do
+        forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal
+          { transactionUser                         = uid
+          , transactionQualification                = qid
+          , transactionQualificationScheduleRenewal = Just isUnexpire
+          }
+        updateWhereCount
+          [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
+          [QualificationUserScheduleRenewal =. isUnexpire]
      let msgKind = if upd > 0  then Success else Warning
          msgVal  = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
      addMessageI msgKind msgVal
--- a/src/Handler/SAP.hs
+++ b/src/Handler/SAP.hs
@ -6,6 +6,7 @@

 module Handler.SAP
  ( getQualificationSAPDirectR
+  , compileBlocks -- for Test in Handler.SAPSpec only
  )
  where

@ -18,8 +19,9 @@ import Handler.Utils.Profile
 -- import qualified Data.CaseInsensitive as CI
 import qualified Data.Csv as Csv
 import           Database.Esqueleto.Experimental ((:&)(..))
-import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
 -- import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E


@ -55,22 +57,39 @@ instance ToNamedRecord SapUserTableCsv where
    ]

 -- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
--   TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo
-sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv]
-sapRes2csv l = [ res | (Ex.Value pn@(Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l 
-                --  , let persNoAsInt = readMay =<< persNo -- also see Handler.Utils.Profile.validFraportPersonalNumber
-                --  , persNoAsInt >= Just (10000::Int)       -- filter E-accounts for SAP export
-                --  , persNoAsInt <= Just (99999::Int)       -- filter E-accounts for SAP export                                                     
-                , let res = SapUserTableCsv
-                            { csvSUTpersonalNummer = persNo
-                            , csvSUTqualifikation  = sapId
-                            , csvSUTgültigVon      = firstHeld
-                            , csvSUTgültigBis      = validUntil
-                            -- , csvSUTsupendiertBis  = blocked
-                            , csvSUTausprägung     = "J"
-                            }
-                , validFraportPersonalNumber pn
-               ]
+--   temporary suspensions are transmitted to SAP in multiple rows: firstheld->suspension1, reinstate1->suspension2, reinstate2->validTo
+sapRes2csv :: [(E.Value (Maybe Text), E.Value (Maybe Text), E.Value Day, E.Value Day, E.Value (Maybe [Maybe Day]), E.Value (Maybe [Maybe Bool]))] -> [SapUserTableCsv]
+sapRes2csv = concatMap procRes
+  where 
+    procRes (E.Value pn@(Just persNo), E.Value (Just sapId), E.Value firstHeld, E.Value validUntil, E.Value (fromMaybe [] -> qubFroms), E.Value (fromMaybe [] -> qubUnblocks))
+      | validFraportPersonalNumber pn -- between 10000 and 99999 also see Handler.Utils.Profile.validFraportPersonalNumber
+        = let mkSap (dfrom,duntil) = SapUserTableCsv
+                              { csvSUTpersonalNummer = persNo
+                              , csvSUTqualifikation  = sapId
+                              , csvSUTgültigVon      = dfrom
+                              , csvSUTgültigBis      = duntil                            
+                              , csvSUTausprägung     = "J"
+                              }
+          in fmap mkSap $ compileBlocks firstHeld validUntil $ zipMaybes qubFroms qubUnblocks
+    procRes _ = []
+
+-- | compute a series of valid periods, assume that lists is already sorted by Day
+--   the lists encodes qualification_user_blocks with block=False/unblock=True 
+compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
+compileBlocks dStart dEnd = go (dStart, True) 
+  where 
+    go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)]
+    go (d,s) (p1@(d1,s1):r1@((d2,s2):r2))
+      | s1 == s2 && d <= d1                            = go (d,s) (p1:r2)   -- ignore unnecessary 2nd change      
+      | d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s)     r1    -- ignore unnecessary 1st change      
+    go (d,s) ((d1,s1):r1)
+      | dEnd <= d1        =          go (d ,s ) []                          -- remaining dates extend validity        
+      | s, not s1, d < d1 = (d,d1) : go (d1,s1) r1                          -- valid interval found
+      | s == s1           =          go (d ,s ) r1                          -- no change
+      | otherwise         =          go (d1,s1) r1                          -- ignore invalid interval
+    go (d,s) []
+      | s         = [(d,dEnd)]
+      | otherwise = []

 -- | Deliver all employess with a successful LDAP synch within the last 3 months
 getQualificationSAPDirectR :: Handler TypedContent
@ -78,23 +97,36 @@ getQualificationSAPDirectR = do
  now   <- liftIO getCurrentTime  
  fdate <- formatTime' "%Y%m%d_%H-%M" now 
  let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
-  qualUsers <- runDB $ Ex.select $ do
-    (qual :& qualUser :& user) <- 
-      Ex.from $ Ex.table @Qualification 
-      `Ex.innerJoin` Ex.table @QualificationUser
-      `Ex.on` (\(qual :& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification)
-      `Ex.innerJoin` Ex.table @User
-      `Ex.on` (\(_ :& qualUser :& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId)
-    Ex.where_ $ E.isJust (qual Ex.^. QualificationSapId)
-        Ex.&&.  E.isJust (user Ex.^. UserCompanyPersonalNumber)
-        Ex.&&.  E.isJust (user Ex.^. UserLastLdapSynchronisation)
-        Ex.&&.  (E.justVal ldap_cutoff Ex.<=. user Ex.^. UserLastLdapSynchronisation)
+  qualUsers <- runDB $ E.select $ do
+    (qual :& qualUser :& user :& qualBlock) <- 
+      E.from $ E.table @Qualification 
+      `E.innerJoin` E.table @QualificationUser
+      `E.on` (\(qual :& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
+      `E.innerJoin` E.table @User
+      `E.on` (\(_ :& qualUser :& user) -> qualUser E.^. QualificationUserUser E.==. user E.^. UserId)
+      `E.leftJoin` E.table @QualificationUserBlock
+      `E.on` (\(_ :& qualUser :& _ :& qualBlock) -> 
+                  qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
+          E.&&.   E.val now                         E.>~. qualBlock E.?. QualificationUserBlockFrom
+        )
+    E.where_ $ E.isJust (qual E.^. QualificationSapId)
+        E.&&.  E.isJust (user E.^. UserCompanyPersonalNumber)
+        E.&&.  E.isJust (user E.^. UserLastLdapSynchronisation)
+        E.&&.  (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation)
+    E.groupBy ( user      E.^. UserCompanyPersonalNumber
+              , qualUser  E.^. QualificationUserFirstHeld
+              , qualUser  E.^. QualificationUserValidUntil                
+              , qual      E.^. QualificationSapId
+              )
+    let blockOrder = [E.asc $ qualBlock E.?. QualificationUserBlockFrom, E.asc $ qualBlock E.?. QualificationUserBlockId]
+        -- blockAgg f = E.arrayAggWith E.AggModeAll (qualBlock E.^. f) blockOrder
    return 
-      ( user      Ex.^. UserCompanyPersonalNumber
-      , qualUser  Ex.^. QualificationUserFirstHeld
-      , qualUser  Ex.^. QualificationUserValidUntil
-      -- , qualUser  Ex.^. QualificationUserBlockedDue
-      , qual      Ex.^. QualificationSapId
+      ( user      E.^. UserCompanyPersonalNumber
+      , qual      E.^. QualificationSapId
+      , qualUser  E.^. QualificationUserFirstHeld
+      , qualUser  E.^. QualificationUserValidUntil
+      , E.arrayAggWith E.AggModeAll (E.dayMaybe $ qualBlock E.?. QualificationUserBlockFrom   ) blockOrder
+      , E.arrayAggWith E.AggModeAll (             qualBlock E.?. QualificationUserBlockUnblock) blockOrder
      )    
  let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers
      fmtOpts = (review csvPreset CsvPresetRFC)
--- a/src/Handler/Tutorial/Users.hs
+++ b/src/Handler/Tutorial/Users.hs
@ -139,8 +139,9 @@ postTUsersR tid ssh csh tutn = do
    (TutorialUserGrantQualificationData{..}, selectedUsers)
      | tuQualification `Set.member` courseQids -> do
        -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
-        today <- utctDay <$> liftIO getCurrentTime
-        runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
+        today <- liftIO getCurrentTime
+        let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
+        runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason
        addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
        redirect $ CTutorialR tid ssh csh tutn TUsersR
    (TutorialUserRenewQualificationData{..}, selectedUsers)
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@ -106,11 +106,11 @@ postUsersR = 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)]
-              return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
-            let companies = intersperse (text2markup ", ") $
-                  (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
-                icnSuper = text2markup " " <> icon IconSupervisor
-            pure $ toWgt $ mconcat companies
+              return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)            
+            let icnSuper  = toWidget $ text2markup " " <> icon IconSupervisor
+                companies = 
+                  (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
+            pure $ intercalate (text2widget "; ") companies
      , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
          (AdminUserR <$> encrypt uid)
          (toWgt userCompanyPersonalNumber)
--- a/src/Handler/Utils/DateTime.hs
+++ b/src/Handler/Utils/DateTime.hs
@ -1,4 +1,4 @@
-- 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>
+-- SPDX-FileCopyrightText: 2022-23 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

--- a/src/Handler/Utils/LMS.hs
+++ b/src/Handler/Utils/LMS.hs
@ -39,6 +39,7 @@ import Import
 import Handler.Utils.DateTime
 import Handler.Utils.Csv
 import Data.Csv (HasHeader(..), FromRecord)
+import qualified Data.Text as Text

 import qualified Data.Set as Set  (notMember)
 import qualified Database.Esqueleto.Legacy as E
@ -130,11 +131,16 @@ makeLmsFilename ftag (citext2lower -> qsh) = do
 getYMTH :: MonadHandler m => m Text
 getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime

--
-lmsDeletionDate :: Handler UTCTime
-lmsDeletionDate = do
+-- | Given the QualificationAuditDuration, determines the time to signal the deletion of an LMS User to the e-learning server. Note that the e-learning server ought to delete LMS users on its own
+lmsDeletionDate :: Maybe Int -> Handler UTCTime
+lmsDeletionDate mbMaxAuditMonths = do
+  now <- liftIO getCurrentTime
  LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
-  addLocalDays (fromIntegral $ negate lmsDeletionDays) <$> liftIO getCurrentTime
+  let ldd = addDiffDaysRollOver (fromDays $ negate lmsDeletionDays) now
+  return $ case mbMaxAuditMonths of
+    Nothing -> ldd
+    (Just maxAuditMonths) -> 
+      max ldd (addDiffDaysRollOver (fromMonths $ negate maxAuditMonths) now)

 -- | Decide whether LMS platform should delete an identifier
 lmsUserToDeleteExpr :: UTCTime -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool)
@ -196,7 +202,7 @@ maxLmsUserIdentRetries = 27
 randomText :: MonadIO m => String -> Int -> m Text
 randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
  where
-    num_letters = ['2'..'9'] ++ ['a'..'h'] ++ ['j','k'] ++ ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these; apc has trouble distinguishing i/j
+    num_letters = ['2'..'9'] ++ ['a'..'h'] ++ 'k' : ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these; apc has trouble distinguishing i/j and read "ji", "jf" as ligatures "ij", "fj" so we eliminate j as well 
    range       = extra ++ num_letters

 --TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though
@ -206,14 +212,15 @@ randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
 --   where
 --     eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True }

-randomLMSIdent :: MonadIO m => m LmsIdent
-randomLMSIdent = LmsIdent <$> randomText [] lengthIdent -- idents must not contain '_' nor '-'
+randomLMSIdent :: MonadIO m => Maybe Char -> m LmsIdent
+randomLMSIdent Nothing  = LmsIdent . Text.cons 'j'  <$> randomText [] (pred lengthIdent) -- idents must not contain '_' nor '-'
+randomLMSIdent (Just c) = LmsIdent . Text.cons  c   <$> randomText [] (pred lengthIdent)

-randomLMSIdentBut :: MonadIO m => Set LmsIdent -> m (Maybe LmsIdent)
-randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
+randomLMSIdentBut :: MonadIO m => Maybe Char -> Set LmsIdent -> m (Maybe LmsIdent)
+randomLMSIdentBut prefix banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
  where
    getIdentOk = do
-      l <- randomLMSIdent
+      l <- randomLMSIdent prefix
      return $ toMaybe (Set.notMember l banList) l

 randomLMSpw :: MonadIO m => m Text -- may contain all kinds of symbols, but our users had trouble with some, like ',' '.' ':' '_'
@ -255,23 +262,20 @@ lmsStatusIcon LmsSuccess{} = IconOK
 lmsStatusIcon LmsExpired{} = IconExpired
 lmsStatusIcon _other       = IconNotOK

-lmsUserStatusWidget :: Bool -> LmsUser -> Widget
-lmsUserStatusWidget adminInfo luser = case luser of
+lmsUserStatusWidget :: Bool -> Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> Widget
+lmsUserStatusWidget adminInfo mbLink luser = case luser of
    LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=mbDay} ->
      [whamlet|$newline never
-        $maybe aday <- mbDay
-          ^{formatTimeW SelFormatDateTime aday}
-        $nothing
-          --.--.----
+        ^{dateWgt mbDay}
        \ ^{iconFixed (lmsStatusIcon lStat)}
        $if adminInfo
          \ ^{lockIcon}
          \ ^{resetIcon}
      |]

-    LmsUser{lmsUserNotified=Just d} ->
+    LmsUser{lmsUserNotified=mbDay@(Just _)} ->
      [whamlet|$newline never
-        ^{formatTimeW SelFormatDateTime d}
+        ^{dateWgt mbDay}
        \ ^{iconFixed IconNotificationSent}
        $if adminInfo
          \ ^{lockIcon}
@ -280,7 +284,7 @@ lmsUserStatusWidget adminInfo luser = case luser of

    LmsUser{lmsUserStarted=dstart} | adminInfo ->  -- E-Learning started, but not yet notified; only intended for Admins;
      [whamlet|$newline never
-        ^{formatTimeW SelFormatDateTime dstart}
+        ^{dateWgt (Just dstart)}
        \ ^{iconFixed IconPlanned}
        $if adminInfo
          \ ^{resetIcon}
@ -297,3 +301,12 @@ lmsUserStatusWidget adminInfo luser = case luser of
    resetIcon
      | lmsUserResetTries luser = iconFixed IconResetTries
      | otherwise = mempty
+
+    dateWgt :: Maybe UTCTime -> Widget
+    dateWgt =
+      let mkDayWgt = maybe (text2widget "--.--.----") (formatTimeW SelFormatDateTime)
+      in case mbLink of 
+        Nothing       -> mkDayWgt
+        (Just mkLink) -> \mbDay -> do
+          uuid <- liftHandler $ encrypt $ luser ^. _lmsUserUser
+          modal (mkDayWgt mbDay) $ Left $ SomeRoute $ mkLink uuid
--- a/src/Handler/Utils/Qualification.hs
+++ b/src/Handler/Utils/Qualification.hs
@ -41,47 +41,32 @@ isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _quali
 -- SQL Snippets --
 ------------------

-- | Recently became invalid or blocked and not yet notified
-quserToNotify :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool)
-quserToNotify quser cutoff =                                                                                        -- recently invalid or...
-  (       E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil
-    E.&&. E.notExists (do
-        qualUserBlock <- E.from $ E.table @QualificationUserBlock
-        E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
-          E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>.  quser E.^. QualificationUserLastNotified
-          E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
-          E.&&. E.notExists (do                                                                                     --   block is the most recent block
-            qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock
-            E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock)
-                      qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
-                E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
-          )
-      )
-  ) E.||. E.exists (do                                                                                              -- ...recently blocked
-    qualUserBlock <- E.from $ E.table @QualificationUserBlock
-    E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)                                            --   block is not an unblock
-        E.&&. E.day (qualUserBlock E.^. QualificationUserBlockFrom) E.<.  quser E.^. QualificationUserValidUntil    --   block was essential during validity
-        E.&&.        qualUserBlock E.^. QualificationUserBlockFrom  E.>.  quser E.^. QualificationUserLastNotified  --   block has not yet been communicated
-        E.&&.        qualUserBlock E.^. QualificationUserBlockFrom  E.<=. E.val cutoff                              --   block is already active
-        E.&&. E.notExists (do                                                                                       --   block is the most recent block
-            qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock
-            E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock))
-                      qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
-                E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
-          )
-  )
+-- | Recently became invalid or blocked and not yet notified; assumes that second argument is latest active block (if exists), also checks validity with respect to given timestamp
+quserToNotify :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value Bool)
+quserToNotify cutoff quser qblock = -- either recently become invalid with no prior block or recently blocked
+      -- has expired without being blocked
+                quser E.^. QualificationUserScheduleRenewal
+      E.&&. ((  quser E.^. QualificationUserValidUntil E.<. E.val  (utctDay cutoff)
+          E.&&. quser E.^. QualificationUserValidUntil E.>. E.day  (quser E.^. QualificationUserLastNotified)
+          E.&&. E.not_ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked
+        ) E.||. ( -- was recently blocked
+                        E.isFalse (qblock E.?. QualificationUserBlockUnblock) 
+          E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified)
+        ))

-- condition to ensure that the lastes QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
+-- condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
 isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
 isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
    newerBlock <- E.from $ E.table @QualificationUserBlock
    E.where_ $          newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
        E.&&.           newerBlock E.^. QualificationUserBlockFrom              E.<=. cutoff
+        E.&&.    E.just(newerBlock E.^. QualificationUserBlockId)               E.!=. qualBlock E.?. QualificationUserBlockId
        E.&&.  ((E.just(newerBlock E.^. QualificationUserBlockFrom)             E.>.  qualBlock E.?. QualificationUserBlockFrom)
          E.||. (       newerBlock E.^. QualificationUserBlockUnblock           -- in case of equal timestamps, any unblock wins
                 E.&&. (newerBlock E.^. QualificationUserBlockFrom              E.=?. qualBlock E.?. QualificationUserBlockFrom)
-               ))           
+               ))
  )
+
 -- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
 quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
 quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do 
@ -148,8 +133,9 @@ selectRelevantBlock cutoff quid =
 ------------------------


-upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking
-upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
+upsertQualificationUser :: QualificationId -> UTCTime -> Day -> Maybe Bool -> Text -> UserId -> DB () -- ignores blocking
+upsertQualificationUser  qualificationUserQualification startTime qualificationUserValidUntil mbScheduleRenewal reason qualificationUserUser = do
+  let qualificationUserLastRefresh = utctDay startTime
  Entity quid _ <- upsert
    QualificationUser
      { qualificationUserFirstHeld        = qualificationUserLastRefresh      
@ -164,7 +150,8 @@ upsertQualificationUser  qualificationUserQualification qualificationUserLastRef
      , QualificationUserLastRefresh        =. qualificationUserLastRefresh      
      ]
    )
-  
+  authUsr <- liftHandler maybeAuthId
+  insert_ $ QualificationUserBlock quid True startTime reason authUsr
  audit TransactionQualificationUserEdit
    { transactionQualificationUser            = quid
    , transactionQualification                = qualificationUserQualification
@ -198,8 +185,8 @@ renewValidQualificationUsers qid renewalTime uids =
    Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
      cutoff <- maybe (liftIO getCurrentTime) return renewalTime
      quEntsAll <- selectValidQualifications qid uids cutoff
-      let cutoffday     = utctDay cutoff
-          maxValidTo  = addGregorianMonthsRollOver (toInteger renewalMonths) cutoffday
+      let cutoffday   = utctDay cutoff
+          maxValidTo  = addGregorianMonthsRollOver (toInteger $ renewalMonths `div` 2) cutoffday
          quEnts      = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
      forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do 
        let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil        
@ -216,7 +203,7 @@ renewValidQualificationUsers qid renewalTime uids =
      return $ length quEnts
    _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.

-- | Block or unblock some users for a given reason 
+-- | Block or unblock some users for a given reason, but only if they are not already blocked (essential assumption that is actually used)
 qualificationUserBlocking :: 
  ( AuthId (HandlerSite m) ~ Key User
  , IsPersistBackend (YesodPersistBackend (HandlerSite m))
@ -261,7 +248,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReason
                      , qualificationUserBlockBlocker           = authUsr
                      })) toChange
  E.insertMany_ (snd <$> newBlocks)
-  unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. now]
+  unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. addUTCTime 1 blockTime]
  forM_ newBlocks $ \(uid, qub) -> audit TransactionQualificationUserBlocking
    { transactionQualification      = qid
    , transactionUser               = uid
--- a/src/Handler/Utils/Table/Cells.hs
+++ b/src/Handler/Utils/Table/Cells.hs
@ -307,6 +307,16 @@ courseCell Course{..} = anchorCell link name `mappend` desc
                ^{modal "Beschreibung" (Right $ toWidget descr)}
              |]

+companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a
+companyCell cid cname isSupervisor = anchorCell link name
+  where
+    link = FirmR cid
+    corg = ciOriginal cname
+    name 
+      | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
+      | otherwise    = text2markup  corg
+
+
 qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
 qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name
  where
@ -426,10 +436,7 @@ cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a
 cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece

 lmsStatusCell :: IsDBTable m a => Bool -> Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a
-lmsStatusCell extendedInfo Nothing        lu = wgtCell $ lmsUserStatusWidget extendedInfo lu
-lmsStatusCell extendedInfo (Just toLink)  lu = cell $ do 
-  uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser
-  modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid)
+lmsStatusCell extendedInfo mkLink = wgtCell . lmsUserStatusWidget extendedInfo mkLink

 lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a
 lmsStateCell LmsFailed  = iconBoolCell False
--- a/src/Jobs/Handler/LMS.hs
+++ b/src/Jobs/Handler/LMS.hs
@ -34,7 +34,7 @@ import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries
 import Handler.Utils.Qualification

 import qualified Data.CaseInsensitive as CI
-
+import qualified Data.Text as Text

 dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
 dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
@ -125,6 +125,9 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
  where
    act :: YesodJobDB UniWorX ()
    act = do
+      quali <- getJust qid -- may throw an error, aborting the job
+      let qshort  = CI.original $ qualificationShorthand quali
+          qprefix = fst <$> Text.uncons (Text.toLower qshort)
      identsInUseVs <- E.select $ do
        lui <- E.from $

@ -158,9 +161,9 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
          -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
          startLmsUser = do
            lpw <- randomLMSpw
-            maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut identsInUse)
+            maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
            -- runMaybeT $ do
-            --   lid <- MaybeT $ randomLMSIdentBut identsInUse
+            --   lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
            --   MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid                            
      inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
      case inserted of
@ -186,31 +189,39 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
      $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
      now <- liftIO getCurrentTime      
      -- end users that expired by doing nothing
-      expiredLearners <- E.select $ do
+      expiredUsers <- E.select $ do
          (quser :& luser) <- E.from $
            E.table @QualificationUser
-            `E.innerJoin` E.table @LmsUser
+            `E.leftJoin` E.table @LmsUser
            `E.on` (\(quser :& luser) ->
-                              luser E.^. LmsUserUser           E.==. quser   E.^. QualificationUserUser
-                        E.&&. luser E.^. LmsUserQualification  E.==. quser   E.^. QualificationUserQualification)
+                              luser E.?. LmsUserUser           E.?=. quser   E.^. QualificationUserUser
+                        E.&&. luser E.?. LmsUserQualification  E.?=. quser   E.^. QualificationUserQualification)
          E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
-              E.&&.  luser E.^. LmsUserQualification           E.==. E.val qid
-              E.&&.  E.isNothing (luser E.^. LmsUserStatus)
-              E.&&.  E.isNothing (luser E.^. LmsUserEnded)
+              -- E.&&.  luser E.?. LmsUserQualification        E.?=. E.val qid
+              -- E.&&.  E.isNothing (luser E.^. LmsUserStatus)
+              -- E.&&.  E.isNothing (luser E.^. LmsUserEnded)
              E.&&.  E.not_ (validQualification now quser)
-          pure (luser E.^. LmsUserId)
+          pure (quser E.^. QualificationUserUser, luser E.?. LmsUserId)
+      nrBlocked <- qualificationUserBlocking qid (E.unValue . fst <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
+      let expiredLearners = [luid | (_, E.Value (Just luid)) <- expiredUsers]
      nrExpired <- E.updateCount $ \luser -> do
        E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now]
-        E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners)
+        E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
             E.&&.  luser E.^. LmsUserQualification E.==. E.val qid
-      $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
+             E.&&. (luser E.^. LmsUserId) `E.in_` E.valList expiredLearners
+      $logInfoS "LMS" $ "Expired qualification holders " <> tshow nrBlocked <> " and expired lms users " <> tshow nrExpired <> " for qualification " <> qshort

-      when (quali ^. _qualificationExpiryNotification) $ do
+      when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
        notifyInvalidDrivers <- E.select $ do
-            quser <- E.from $ E.table @QualificationUser
-            E.where_ $ E.not_ (quser `qualificationValid` now)                 -- currently invalid
-              E.&&. quser E.^. QualificationUserQualification E.==. E.val qid  -- correct qualification
-              E.&&. quser `quserToNotify` now                                  -- recently became invalid or blocked
+            (quser :& qblock) <- E.from $ 
+              E.table @QualificationUser
+              `E.leftJoin` E.table @QualificationUserBlock
+              `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId
+                        E.&&. qblock `isLatestBlockBefore` E.val now
+                     )
+            E.where_ $ -- E.not_ (validQualification now quser)                   -- currently invalid
+                    quser E.^. QualificationUserQualification E.==. E.val qid  -- correct qualification
+              E.&&. quserToNotify now quser qblock                            -- recently became invalid or blocked
            pure (quser E.^. QualificationUserUser)

        forM_ notifyInvalidDrivers $ \(E.Value uid) ->
@ -254,118 +265,121 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
    act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise)
      now <- liftIO getCurrentTime
      -- DEBUG 2rows; remove later
-      totalrows <- count [LmsReportQualification ==. qid]
+      totalrows <- count [LmsReportQualification ==. qid]      
      $logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid
-      let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now  -- no longer necessary, since LMS reports dates only
-          -- DB query for LmsUserUser, provided a matching LmsReport exists
-          luserQry luFltr repFltr = E.select $ do
-            luser <- E.from $ E.table @LmsUser
-            E.where_ $  E.val qid E.==. luser E.^. LmsUserQualification
-                  E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
-                  E.&&. luFltr luser
-                  E.&&. E.exists (do
+      when (totalrows > 0) $ do
+        let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now  -- no longer necessary, since LMS reports dates only
+            -- DB query for LmsUserUser, provided a matching LmsReport exists
+            luserQry luFltr repFltr = E.select $ do
+              luser <- E.from $ E.table @LmsUser
+              E.where_ $  E.val qid E.==. luser E.^. LmsUserQualification
+                    E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
+                    E.&&. luFltr luser
+                    E.&&. E.exists (do
+                      lreport <- E.from $ E.table @LmsReport
+                      E.where_ $ lreport E.^. LmsReportIdent          E.==. luser E.^. LmsUserIdent
+                          E.&&.  lreport E.^. LmsReportQualification  E.==. E.val qid
+                          E.&&.  repFltr luser lreport
+                      )
+              return $ luser E.^. LmsUserUser
+            -- DB query for LmsUser innerJoin LmsReport
+            lrepQry lrFltr = E.select $ do
+              (luser :& lreport) <- E.from $ E.table @LmsUser`E.innerJoin` E.table @LmsReport
+                `E.on` (\(luser :& lreport) ->  luser E.^. LmsUserIdent          E.==. lreport E.^. LmsReportIdent
+                                          E.&&. luser E.^. LmsUserQualification  E.==. lreport E.^. LmsReportQualification)
+              E.where_ $ luser E.^. LmsUserQualification    E.==. E.val qid
+                E.&&.  lreport E.^. LmsReportQualification  E.==. E.val qid
+                E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
+                E.&&. lrFltr luser lreport
+              return (luser, lreport)          
+        -- A) reset status for learners that had their tries just resetted as indicated by LmsOpen
+        E.update $ \luser -> do
+          E.set luser [ LmsUserStatus     E.=. E.nothing
+                      , LmsUserStatusDay  E.=. E.nothing
+                      , LmsUserResetTries E.=. E.false ]
+          E.where_ $  E.val qid E.==. luser E.^. LmsUserQualification
+                E.&&. E.isNothing (luser E.^. LmsUserEnded   ) -- must still exist at server
+                E.&&. E.isJust    (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
+                E.&&. luser E.^. LmsUserResetTries
+                E.&&. E.exists (do
                    lreport <- E.from $ E.table @LmsReport
                    E.where_ $ lreport E.^. LmsReportIdent          E.==. luser E.^. LmsUserIdent
                        E.&&.  lreport E.^. LmsReportQualification  E.==. E.val qid
-                        E.&&.  repFltr luser lreport
-                    )
-            return $ luser E.^. LmsUserUser
-          -- DB query for LmsUser innerJoin LmsReport
-          lrepQry lrFltr = E.select $ do
-            (luser :& lreport) <- E.from $ E.table @LmsUser`E.innerJoin` E.table @LmsReport
-              `E.on` (\(luser :& lreport) ->  luser E.^. LmsUserIdent          E.==. lreport E.^. LmsReportIdent
-                                        E.&&. luser E.^. LmsUserQualification  E.==. lreport E.^. LmsReportQualification)
-            E.where_ $ luser E.^. LmsUserQualification    E.==. E.val qid
-              E.&&.  lreport E.^. LmsReportQualification  E.==. E.val qid
-              E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
-              E.&&. lrFltr luser lreport
-            return (luser, lreport)          
-      -- A) reset status for learners that had their tries just resetted as indicated by LmsOpen
-      E.update $ \luser -> do
-        E.set luser [ LmsUserStatus     E.=. E.nothing
-                    , LmsUserResetTries E.=. E.false ]
-        E.where_ $  E.val qid E.==. luser E.^. LmsUserQualification
-              E.&&. E.isNothing (luser E.^. LmsUserEnded   ) -- must still exist at server
-              E.&&. E.isJust    (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
-              E.&&. luser E.^. LmsUserResetTries
-              E.&&. E.exists (do
-                  lreport <- E.from $ E.table @LmsReport
-                  E.where_ $ lreport E.^. LmsReportIdent          E.==. luser E.^. LmsUserIdent
-                      E.&&.  lreport E.^. LmsReportQualification  E.==. E.val qid
-                      E.&&.  lreport E.^. LmsReportResult         E.==. E.val LmsOpen
-                      E.&&.  lreport E.^. LmsReportLock           E.==. E.true
-                )
-      -- B) notify all newly reported users that lms is available
-      let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived  -- not seen before, just starting
-          notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
-       in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
-      -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit)
-      let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
-          procBlock (Entity luid luser, Entity _ lreport) = do 
-              let repDay = lmsReportDate lreport <|> Just now
-              ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log
-              update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay]
-              return $ Sum ok_block
-       in lrepQry lrFltrBlock 
-                    >>= foldMapM procBlock 
-                    >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later
-      -- D) renew qualifications for all successfull learners
-      let lrFltrSuccess luser lreport = (E.isNothing (luser E.^. LmsUserStatus) E.||. luser E.^. LmsUserStatus E.!=. E.justVal LmsSuccess) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed -- LMS WORKAROUND 1: LmsPassed replaces any other status
-          procRenew (Entity luid luser, Entity _ lreport) = do
-              let repDay = lmsReportDate lreport <|> Just now
-              -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-              -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning                  
-              -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
-              -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|])
-              -- END LMS WORKAROUND 2
-              ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
-              update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay]
-              return $ Sum ok_renew
-       in lrepQry lrFltrSuccess 
-                    >>= foldMapM procRenew
-                    >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later
-      -- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
-      E.update $ \luser -> do
-        E.set luser [ LmsUserEnded E.=. E.justVal now ]
-        E.where_ $  E.val qid E.==. luser E.^. LmsUserQualification
-              E.&&. E.isNothing (luser E.^. LmsUserEnded   )
-              E.&&. E.isJust    (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
-              E.&&. E.notExists (do
-                  lreport <- E.from $ E.table @LmsReport
-                  E.where_ $ lreport E.^. LmsReportIdent          E.==. luser E.^. LmsUserIdent
-                      E.&&.  lreport E.^. LmsReportQualification  E.==. E.val qid
-                )
-
-      -- F) lock expired learners: happens during JobLmsDequeue only
-      -- G) update lock and received
-      let updateReceivedLocked lockstatus = E.updateCount $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice
-            E.set luser [ LmsUserReceived E.=. E.justVal now
-                        , LmsUserLocked   E.=. E.val lockstatus ]
-            E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
-                E.&&. E.isNothing (luser E.^. LmsUserEnded)
-                E.&&. E.exists (do
-                    lreport <- E.from $ E.table @LmsReport
-                    E.where_ $  lreport E.^. LmsReportIdent         E.==. luser E.^. LmsUserIdent
-                          E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
-                          E.&&. lreport E.^. LmsReportLock          E.==. E.val lockstatus            -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
+                        E.&&.  lreport E.^. LmsReportResult         E.==. E.val LmsOpen
+                        E.&&.  lreport E.^. LmsReportLock           E.==. E.true
                  )
-      -- NOTE: this code leads to a runtime errror; apparently from-clauses are not allowed in updates yet
-      -- let updateReceivedLocked lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL
-      --       E.set luser [ LmsUserReceived E.=. E.justVal now
-      --                   , LmsUserLocked   E.=. E.val lockstatus ]
-      --       lreport <- E.from $ E.table @LmsReport
-      --       E.where_ $ E.isNothing (luser E.^. LmsUserEnded)
-      --           E.&&. luser   E.^. LmsUserQualification   E.==. E.val qid
-      --           E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
-      --           E.&&. lreport E.^. LmsReportIdent         E.==. luser E.^. LmsUserIdent
-      --           E.&&. lreport E.^. LmsReportLock          E.==. E.val lockstatus            -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
-      updateReceivedLocked False
-        >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
-      updateReceivedLocked True
-        >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later
-      -- G) Truncate LmsReport for qid and log
-      repProc <- deleteWhereCount [LmsReportQualification ==. qid]
-      $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]
+        -- B) notify all newly reported users that lms is available
+        let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived  -- not seen before, just starting
+            notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
+          in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
+        -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry
+        let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
+            procBlock (Entity luid luser, Entity _ lreport) = do 
+                let repDay = lmsReportDate lreport <|> Just now
+                ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log
+                update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay]
+                return $ Sum ok_block
+          in lrepQry lrFltrBlock 
+                >>= foldMapM procBlock 
+                >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later
+        -- D) renew qualifications for all successfull learners
+        let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed
+            procRenew (Entity luid luser, Entity _ lreport) = do
+                let repDay = lmsReportDate lreport <|> Just now
+                -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
+                -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning                  
+                -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
+                -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|])
+                -- END LMS WORKAROUND 2
+                ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
+                update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay]
+                return $ Sum ok_renew
+          in lrepQry lrFltrSuccess 
+                >>= foldMapM procRenew
+                >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later
+        -- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
+        E.update $ \luser -> do
+          E.set luser [ LmsUserEnded E.=. E.justVal now ]
+          E.where_ $  E.val qid E.==. luser E.^. LmsUserQualification
+                E.&&. E.isNothing (luser E.^. LmsUserEnded   )
+                E.&&. E.isJust    (luser E.^. LmsUserStatus  ) -- status is decided
+                E.&&. E.isJust    (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
+                E.&&. E.notExists (do
+                    lreport <- E.from $ E.table @LmsReport
+                    E.where_ $ lreport E.^. LmsReportIdent          E.==. luser E.^. LmsUserIdent
+                        E.&&.  lreport E.^. LmsReportQualification  E.==. E.val qid
+                  )
+
+        -- F) lock expired learners: happens during JobLmsDequeue only
+        -- G) update lock and received
+        let updateReceivedLocked lockstatus = E.updateCount $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice
+              E.set luser [ LmsUserReceived E.=. E.justVal now
+                          , LmsUserLocked   E.=. E.val lockstatus ]
+              E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
+                  -- E.&&. E.isNothing (luser E.^. LmsUserEnded) -- should always be true, but maybe there is a bug?
+                  E.&&. E.exists (do
+                      lreport <- E.from $ E.table @LmsReport
+                      E.where_ $  lreport E.^. LmsReportIdent         E.==. luser E.^. LmsUserIdent
+                            E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
+                            E.&&. lreport E.^. LmsReportLock          E.==. E.val lockstatus            -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
+                    )
+        -- NOTE: this code leads to a runtime errror; apparently from-clauses are not allowed in updates yet
+        -- let updateReceivedLocked lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL
+        --       E.set luser [ LmsUserReceived E.=. E.justVal now
+        --                   , LmsUserLocked   E.=. E.val lockstatus ]
+        --       lreport <- E.from $ E.table @LmsReport
+        --       E.where_ $ E.isNothing (luser E.^. LmsUserEnded)
+        --           E.&&. luser   E.^. LmsUserQualification   E.==. E.val qid
+        --           E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
+        --           E.&&. lreport E.^. LmsReportIdent         E.==. luser E.^. LmsUserIdent
+        --           E.&&. lreport E.^. LmsReportLock          E.==. E.val lockstatus            -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
+        updateReceivedLocked False
+          >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
+        updateReceivedLocked True
+          >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later
+        -- G) Truncate LmsReport for qid and log
+        repProc <- deleteWhereCount [LmsReportQualification ==. qid]
+        $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]


 -- DEPRECATED processes received results and lengthen qualifications, if applicable
--- a/src/Jobs/Handler/Print.hs
+++ b/src/Jobs/Handler/Print.hs
@ -47,7 +47,7 @@ dispatchJobPrintAck = JobHandlerException act
                            return True
                _       ->  return False
            procOneId oks Entity{entityKey=paid, entityVal=PrintAcknowledge{printAcknowledgeApcIdent=Text.strip -> apci, printAcknowledgeTimestamp=ackt}} =
-                andM [ackOneId ackt $ ftrans apci | ftrans <- ftransAliases] >>= \case
+                orM [ackOneId ackt $ ftrans apci | ftrans <- ftransAliases] >>= \case
                  True  -> delete paid                                      >> return (succ oks)
                  False -> update paid [PrintAcknowledgeProcessed =. True]  >> return oks
        apcis <- selectList [PrintAcknowledgeProcessed ==. False] [Asc PrintAcknowledgeTimestamp, LimitTo jobPrintAckChunkSize]
--- a/src/Jobs/Handler/SendNotification/Qualification.hs
+++ b/src/Jobs/Handler/SendNotification/Qualification.hs
@ -60,7 +60,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
      let expDay  = maybe qualificationUserValidUntil (min qualificationUserValidUntil . utctDay . qualificationUserBlockFrom) block
          qname   = CI.original qualificationName
          qshort  = CI.original qualificationShorthand
-          letter  = LetterExpireQualification 
+          letter  = LetterExpireQualification
            { leqHolderCFN  = encRecShort
            , leqHolderID   = jRecipient
            , leqHolderDN   = userDisplayName
@ -72,14 +72,14 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
            , leqSchool     = qualificationSchool
            , leqUrl        = pure . urender $ ForProfileDataR encRecipient
            }
-      if expDay > utctDay qualificationUserLastNotified 
+      if expDay > utctDay qualificationUserLastNotified
        then do
          notifyOk <- sendEmailOrLetter jRecipient letter
          if notifyOk
-            then do               
+            then do
              runDB $ update quId [QualificationUserLastNotified =. now]
              $logInfoS  "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
-            else 
+            else
              $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname
        else  $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname
    _ ->  $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification
@ -89,7 +89,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
 dispatchNotificationQualificationRenewal :: QualificationId -> Bool -> UserId -> Handler ()
 dispatchNotificationQualificationRenewal nQualification nReminder jRecipient = do
  encRecipient :: CryptoUUIDUser <- encrypt jRecipient
-  query <- runDB $ (,,,) 
+  query <- runDB $ (,,,)
    <$> get jRecipient
    <*> get nQualification
    <*> getBy (UniqueQualificationUser    nQualification jRecipient)
--- a/src/Model/Types/Lms.hs
+++ b/src/Model/Types/Lms.hs
@ -59,11 +59,13 @@ instance Csv.ToField LmsStatus where
 data QualificationBlockStandardReason
      = QualificationBlockFailedELearning
      | QualificationBlockReturnedByCompany
+      | QualificationBlockExpired
  deriving (Eq, Ord, Enum, Bounded, Universe, Finite)

 instance Show QualificationBlockStandardReason where
  show QualificationBlockFailedELearning    = "E-Learning durchgefallen"
  show QualificationBlockReturnedByCompany  = "Rückgabe Firma"
+  show QualificationBlockExpired            = "Abgelaufen"

 qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text
 qualificationBlockedReasonText = 
--- a/src/Utils.hs
+++ b/src/Utils.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@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-23 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>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later

@ -305,6 +305,10 @@ tshowCrop = cropText . tshow
 stripCI :: Text -> CI Text 
 stripCI = CI.mk . Text.strip

+-- | just to avoid adding an import for this
+ciOriginal :: CI Text -> Text 
+ciOriginal = CI.original
+
 citext2lower :: CI Text -> Text 
 citext2lower = Text.toLower . CI.original

@ -312,6 +316,9 @@ citext2lower = Text.toLower . CI.original
 citext2string :: CI Text -> String 
 citext2string = Text.unpack . CI.original

+string2citext :: String -> CI Text
+string2citext = CI.mk . Text.pack
+
 -- | Convert or remove all non-ascii  characters, e.g. for filenames 
 text2asciiAlphaNum :: Text -> Text
 text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c)
@ -357,6 +364,9 @@ text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c)
 text2Html :: Text -> Html
 text2Html = toHtml

+citext2Html :: CI Text -> Html
+citext2Html = toHtml . CI.original  
+
 char2Text :: Char -> Text
 char2Text c 
  | isSpace c = "<Space>"
@ -665,6 +675,11 @@ lastMaybe' l = fmap snd $ l ^? _Snoc
 minimumMaybe :: (MonoFoldable mono, Ord (Element mono)) => mono -> Maybe (Element mono)
 minimumMaybe = fmap minimum . fromNullable

+zipMaybes :: [Maybe a] -> [Maybe b] -> [(a,b)]
+zipMaybes (Just x:xs) (Just y:ys) = (x,y) : zipMaybes xs ys
+zipMaybes      (_:xs)      (_:ys) =         zipMaybes xs ys
+zipMaybes        _              _ = []
+
 -- | Merge/Add any attribute-value pair to an existing list of such pairs.
 --   If the attribute exists, the new valu will be prepended, separated by a single empty space
 insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)]
@ -1161,9 +1176,7 @@ guardMOnM b x = guardM b *> x
 -- Some Utility Functions from Agda.Utils.Monad
 -- | Monadic if-then-else.
 ifM :: Monad m => m Bool -> m a -> m a -> m a
-ifM c m m' =
-    do  b <- c
-        if b then m else m'
+ifM c x y = c >>= bool y x

 -- | @ifNotM mc = ifM (not <$> mc)@  from Agda.Utils.Monad
 ifNotM :: Monad m => m Bool -> m a -> m a -> m a
--- a/src/Utils/Icon.hs
+++ b/src/Utils/Icon.hs
@ -114,6 +114,7 @@ data Icon
  | IconLocked
  | IconUnlocked
  | IconResetTries -- also see IconReset
+  | IconCompany
  deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
  deriving anyclass (Universe, Finite, NFData)

@ -205,6 +206,7 @@ iconText = \case
    IconLocked                  -> "lock"
    IconUnlocked                -> "lock-open-alt"
    IconResetTries              -> "trash-undo"
+    IconCompany                 -> "building"

 nullaryPathPiece ''Icon $ camelToPathPiece' 1
 deriveLift ''Icon
--- a/stack.nix
+++ b/stack.nix
@ -2,12 +2,12 @@
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later

-{ ghc, nixpkgs ? import ./nixpkgs.nix }:
+{ ghc, nixpkgs ? import <nixpkgs> {} }:

 let
  # haskellPackages = import ./stackage.nix { inherit nixpkgs; };
  haskellPackages = pkgs.haskellPackages;
-  inherit (nixpkgs {}) pkgs;
+  inherit (nixpkgs) pkgs;
 in pkgs.haskell.lib.buildStackProject {
  inherit ghc;
  inherit (haskellPackages) stack;
--- a/templates/lms-user.hamlet
+++ b/templates/lms-user.hamlet
@ -43,7 +43,7 @@ $else
              <dd .deflist__dd>^{formatTimeW SelFormatDateTime (lmsUserStarted lmsUsr)}
              $maybe _ <- lmsUserStatus lmsUsr
                <dt .deflist__dt>_{MsgTableLmsStatus}
-                <dd .deflist__dd>^{lmsUserStatusWidget True lmsUsr}
+                <dd .deflist__dd>^{lmsUserStatusWidget True Nothing lmsUsr}
              <dt .deflist__dt>_{MsgTableLmsIdent}
              <dd .deflist__dd>
                <a href=@{LmsIdentR (qualificationSchool quali) (qualificationShorthand quali) (lmsUserIdent lmsUsr)}>
--- a/templates/lms.hamlet
+++ b/templates/lms.hamlet
@ -1,6 +1,6 @@
 $newline never

-$# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+$# SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later

@ -15,11 +15,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
    <dd .deflist__dd>_{MsgMonths (fromIntegral dvalid)}

  $maybe daudit <- qualificationAuditDuration quali
-    <dt .deflist__dt>_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget MsgQualificationAuditDurationTooltip) Nothing True}
+    <dt .deflist__dt>_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget (MsgQualificationAuditDurationTooltip lmsDeletionDays)) Nothing True}
    <dd .deflist__dd>_{MsgMonths (fromIntegral daudit)}      

  $maybe drefresh <- qualificationRefreshWithin quali
-    <dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}
+    <dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget  MsgQualificationRefreshWithinTooltip) Nothing True}
    <dd .deflist__dd>
      $with drm <- cdMonths drefresh
        $with drd <- cdDays drefresh
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@ -569,7 +569,7 @@ fillDb = do
        userDisplayEmail' = CI.mk $ case userSurname of 
          "Walker"    -> "AVSNO:" <> userMatrikelnummer'
          "Clark"     ->      "E" <> userMatrikelnummer' <> "@fraport.de"
-          "Elizabeth" -> ""
+          "Jackson"   -> ""
          _           -> userIdent

  matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
@ -636,6 +636,11 @@ fillDb = do
  void . insert' $ UserCompany fhamann bpol         False  False 
  void . insert' $ UserCompany fhamann ffacil       True   True 
  void . insert' $ UserCompany fhamann nice         False  False
+  -- need more tests
+  insertMany_ [UserCompany uid fraGround False False| Entity uid User{userFirstName = "John"} <- matUsers]
+  insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
+  insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"]
+  insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers]
  -- void . insert' $ UserSupervisor jost gkleen       True
  -- void . insert' $ UserSupervisor jost svaupel      False
  -- void . insert' $ UserSupervisor jost sbarth       False
@ -647,13 +652,17 @@ fillDb = do
              , UserSupervisor jost svaupel      False
              , UserSupervisor jost sbarth       False
              , UserSupervisor jost tinaTester   True
+              , UserSupervisor jost jost         True
              , UserSupervisor svaupel gkleen    False
              , UserSupervisor svaupel fhamann   True
              , UserSupervisor sbarth tinaTester True
              , UserSupervisor gkleen fhamann    False
+              , UserSupervisor gkleen gkleen     True
+              , UserSupervisor tinaTester tinaTester False
              ] 
-              ++ take 333 [ UserSupervisor fhamann uid False | Entity uid _ <-          matUsers ]
-              ++ take 111 [ UserSupervisor gkleen  uid False | Entity uid _ <- drop 300 matUsers ]
+              ++ take 333 [ UserSupervisor fhamann uid True  | Entity uid _ <-          matUsers ]
+              ++ take 111 [ UserSupervisor gkleen  uid True  | Entity uid _ <- drop 300 matUsers ]
+              ++ take  11 [ UserSupervisor jost    uid False | Entity uid _ <- drop 401 matUsers ]
  upsertManyWhere supvs [] [] [] 
  -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok  
  -- insertMany_ supvs              -- NOTE: multiple calls like this throw an error!
@ -726,16 +735,18 @@ fillDb = do

  qidfUsers <- Set.fromAscList . fmap (qualificationUserUser . entityVal)
               <$> selectList [QualificationUserQualification ==. qid_f] [Asc QualificationUserUser]
-  insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11)| Entity uid User{userDisplayName=udn} <- take 200 matUsers, uid `Set.notMember` qidfUsers]
-  void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now
+  insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11)    | Entity uid User{userDisplayName=udn} <- take 200 $ drop  2 matUsers, uid `Set.notMember` qidfUsers]
+  insertMany_ [LmsUser qid_f uid (LmsIdent udn) "123456" False now astatus astatusDay now (Just now) (Just now) Nothing False False | Entity uid User{userDisplayName=udn} <- take 200 $ drop 22 matUsers, uid `Set.notMember` qidfUsers
+                , let selsome = odd $ length udn, let astatus = bool Nothing (Just LmsBlocked) selsome, let astatusDay = bool Nothing (Just now) selsome]
+  void . insert' $ LmsResult qid_f (LmsIdent "hijklm" ) (n_day (-1)) now
  void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now
  void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now
-  void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
-  void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True  now
-  void . insert' $ LmsUserlist qid_f (LmsIdent "ijk"    ) False now
-  void . insert' $ LmsUser qid_f jost        (LmsIdent "ijk"    ) "123" False now Nothing Nothing now           Nothing    (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False
-  void . insert' $ LmsUser qid_f svaupel     (LmsIdent "abcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1)     (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False
-  void . insert' $ LmsUser qid_f gkleen      (LmsIdent "hijklmn") "@#!" True  now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True
+  void . insert' $ LmsUserlist qid_f (LmsIdent "hijklm") False now
+  void . insert' $ LmsUserlist qid_f (LmsIdent "abcdef") True  now
+  void . insert' $ LmsUserlist qid_f (LmsIdent "ijk"   ) False now
+  void . insert' $ LmsUser qid_f jost        (LmsIdent "ijk"   ) "123" False now Nothing Nothing now           Nothing    (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False
+  void . insert' $ LmsUser qid_f svaupel     (LmsIdent "bcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1)     (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False
+  void . insert' $ LmsUser qid_f gkleen      (LmsIdent "hiklmn") "@#!" True  now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True
  void . insert' $ LmsUser qid_f tinaTester  (LmsIdent "qwvu")  "45678" True  now (Just LmsSuccess) (Just $ n_day' (-22))  (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing True True
  void . insert' $ LmsUser qid_f maxMuster   (LmsIdent "xyz")  "a1b2c3" False now (Just LmsBlocked) (Just $ n_day' (-11))  (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing True True
  void . insert' $ LmsUser qid_f fhamann     (LmsIdent "123")  "456"    False now Nothing Nothing now Nothing Nothing Nothing False False
--- a/test/Handler/SAPSpec.hs
+++ b/test/Handler/SAPSpec.hs
@ -0,0 +1,127 @@
+-- SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@faport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Handler.SAPSpec where
+
+import TestImport
+-- import ModelSpec ()
+-- import CryptoID
+
+import Handler.SAP
+
+{-
+data BlockIntervalTest = BlockIntervalTest Day Day [(Day,Bool)]
+  deriving (Show, Eq, Ord)
+
+instance Arbitrary BlockIntervalTest where
+  arbitrary = do
+    blocks <- arbitrary
+    case blocks of 
+      [] -> do 
+        dFrom  <- arbitrary
+        dUntil <- arbitrary `suchThat` (dFrom <)
+        return $ BlockIntervalTest dFrom dUntil []
+      ((h,_):t') -> do
+        let ds = ncons h (fst <$> t')
+            dmin = minimum ds
+            dmax = maximum ds
+        dFrom  <- arbitrary `suchThat` (<= dmin)
+        dUntil <- arbitrary `suchThat` (>= dmax)
+        return $ BlockIntervalTest dFrom dUntil $ sort blocks  
+
+  shrink (BlockIntervalTest dFrom dUntil []) 
+    = [BlockIntervalTest dF dU [] | dF <- shrink dFrom, dU <- shrink dUntil, dF < dU]
+  shrink (BlockIntervalTest dFrom dUntil blocks) 
+    = [BlockIntervalTest dFrom dUntil b | b <- shrink blocks, all ((dFrom <=) . fst) b]
+-}
+
+{- These alternative implementations do NOT meet the specifications and thus cannot be used for testing 
+compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
+compileBlocks dfrom duntil []             = [(dfrom, duntil)]
+compileBlocks dfrom duntil [(d,False)]                              
+  | dend <- min duntil d, dfrom < dend    = [(dfrom, dend)] -- redundant, but common case
+  | otherwise                             = []
+compileBlocks dfrom duntil (p1@(d1,u1):p2@(d2,u2):bs)
+  | u1 == u2                              =               compileBlocks dfrom      duntil (p1:bs)   -- superfluous block/unblock
+  | d1 == d2                              =               compileBlocks dfrom      duntil (p2:bs)   -- eliminate same day changes
+  | u2, dfrom < d1, d1 < d2, d2 < duntil  = (dfrom, d1) : compileBlocks d2         duntil     bs    -- block and reinstated later
+compileBlocks dfrom duntil ((_,True ):bs) =               compileBlocks dfrom      duntil     bs    -- superfluous unblock
+compileBlocks dfrom duntil ((d,False):bs) 
+  | dfrom >= d =               compileBlocks dfrom      duntil     bs    -- should only occur if blocks/unblock happened on same day 
+                                                                                                 
+
+cmpBlocks :: BlockIntervalTest -> [(Day,Day)]
+cmpBlocks (BlockIntervalTest dFrom dUntil blocks) = makePeriods dFrom dUntil $ cleanBlocks $ sort blocks
+  where 
+    cleanBlocks ((_,True):r) = cleanBlocks r
+    cleanBlocks (b1@(d1,False):b2@(d2,True):r)
+      | d1 < d1   = b1:b2:cleanBlocks r
+      | otherwise =       cleanBlocks r
+    cleanBlocks (b1@(_,False):  (_,False):r) = cleanBlocks (b1:r)
+    cleanBlocks r@[(_,False)] = r
+    cleanBlocks [] = []
+
+    makePeriods a b ((d1,False):(d2,True):r) 
+      | b > d2 = (a,d1):makePeriods d2 b r
+      | otherwise = [(a,d1)]
+    makePeriods a b [(d,False)] = [(a,min b d)]
+    makePeriods a b _ = [(a,b)]
+-}
+
+
+spec :: Spec
+spec = do 
+  describe "SAP.compileBlocks" $ do
+    it "works on examples" . example $ do
+      let wA = fromGregorian 2002  1 11
+          wE = fromGregorian 2025  4 30
+          w0 = fromGregorian 2001  9 22
+          w1 = fromGregorian 2023  9 22
+          w2 = fromGregorian 2023 10 16
+          wF = fromGregorian 2023 10 17
+          w3 = fromGregorian 2023 11 17
+          w4 = fromGregorian 2024 01 21
+      compileBlocks wA wE []           `shouldBe` [(wA,wE)]
+      compileBlocks wA wE [(w1,False)] `shouldBe` [(wA,w1)]
+      compileBlocks wA wE [(w1,True)]  `shouldBe` [(wA,wE)]
+      compileBlocks wA wE [(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)]
+      compileBlocks wA wE [(wA,False),(w1,True)] `shouldBe` [(w1,wE)]
+      compileBlocks wA wE [(wA,True),(wA,False),(w1,True)]  `shouldBe` [(w1,wE)]
+      compileBlocks wA wE [(wA,False),(wA,True),(w1,True)]  `shouldBe` [(wA,wE)]
+      compileBlocks wA wE [(wA,False),(w1,True),(w2,False)] `shouldBe` [(w1,w2)]
+      compileBlocks wA wE [(w1,False),(w2,True),(w3,True)]  `shouldBe` [(wA,w1),(w2,wE)]    
+      compileBlocks wA wE [(w1,False),(succ w1,True),(succ w1,False),(w2,True)] `shouldBe` [(wA,succ w1),(w2,wE)]
+      compileBlocks wA wE [(w1,False),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)]
+      compileBlocks wA wE [(w0,True),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)]
+      compileBlocks wA wE [(w0,False),(w1,False),(w2,True),(w3,False),(w4,True)] `shouldBe` [(wA,w1),(w2,w3),(w4,wE)]
+      compileBlocks wA wE [(w1,False),(w2,True),(wF,True ),(w3,False)] `shouldBe` [(wA,w1),(w2,w3)]
+      compileBlocks wA wE [(w1,True),(w2,False),(wF,False),(w3,True)]  `shouldBe` [(wA,w2),(w3,wE)]
+      compileBlocks wA wE [(w2,False),(wF,False),(w3,True)] `shouldBe` [(wA,w2),(w3,wE)]
+      compileBlocks wA wE [(w2,False),(wF,False)] `shouldBe` [(wA,w2) ]
+
+    it "handles basic intervals" $ do
+      (d1,d2,d3) <- generate $ do
+        d1 <- arbitrary 
+        d2 <- arbitrary `suchThat` (d1 <)
+        d3 <- arbitrary `suchThat` (d1 <)
+        return (d1,d2,d3)
+      b <- generate arbitrary     
+      let test = compileBlocks d1 d2 [(d3,b)]
+      test `shouldBe` bool [(d1,min d2 d3)] [(d1,d2)] b
+
+    it "identifies two correct intervals" $ do
+      (d1,d2,d3,d4) <- generate $ do
+        d1 <- arbitrary 
+        d2 <- arbitrary `suchThat` (d1 <)
+        d3 <- arbitrary `suchThat` (d1 <)
+        d4 <- arbitrary `suchThat` (d3 <)
+        return (d1,d2,d3,d4)
+      b3 <- generate arbitrary
+      b4 <- generate arbitrary
+      let test   = compileBlocks d1 d2 [(d3,b3),(d4,b4)]
+          result | b3, b4       = [(d1, d2)]
+                 | b3           = [(d1, min d2 d4)]                 
+                 | b4, d2 > d4  = [(d1,d3),(d4,d2)]
+                 | otherwise    = [(d1, min d2 d3)]
+      test `shouldBe` result