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

Note: noticed while working on #225

CHANGELOG.md

@@ -2,6 +2,25 @@
 
 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.79](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.78...v27.4.79) (2024-09-10)
+
+
+### Bug Fixes
+
+* **notifications:** fix [#180](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/180) qualification expiry notification are sent only once ([74f7633](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/74f7633837870448f7cab1013719f42ab49941fe))
+* **supervision:** fix [#181](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/181) by unifying deletion of supervision ([6a070a6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6a070a67756bd4ef4b9b5efc176f34c7ed183f1a))
+
+## [27.4.78](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.77...v27.4.78) (2024-09-05)
+
+
+### Bug Fixes
+
+* **avs:** acs auto synch had inverted success/failure ([4f7855b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4f7855b9ee7133c5ee7e2ca63d63e5d9f060d62f))
+* **avs:** fix [#124](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/124) avs auto synch filter working ([2a27a1e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2a27a1efa673a4245a7e8667bd30c79ac1891b9c))
+* **avs:** fix [#178](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/178) by deleting old superiors for individual users ([ade27e6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ade27e647913ffe4432b41d585b3e00d1c68d4a0))
+* **avs:** typo in superior remark, towards [#178](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/178) ([3c5edb1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3c5edb1b970c8c154d9957837007815b29e23964))
+* **mail:** fix [#179](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/179) by adding download links for PDF attachments ([620e3e4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/620e3e470080831826ccc960dd876e7bb4fcea03))
+
 ## [27.4.77](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.76...v27.4.77) (2024-09-02)
 
 

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

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
+# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -15,11 +15,15 @@ FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht.
 FirmActNotify: Mitteilung versenden
 FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
 FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
+FirmActRemoveSupers: Alle rein firmenbezogenen Ansprechpartnerbeziehungen für diese Personen entfernen?
 FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
+FirmActResetSupersKeepAll: Alle behalten
+FirmActResetSupersRemoveAps: Nur Standardansprechpartner entfernen
+FirmActResetSupersRemoveAll: Alle entfernen
 FirmActAddSupervisors: Ansprechpartner hinzufügen
 FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
 FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
-RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber keine aktiven Ansprechpartnerbeziehungen wurden deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
+RemoveSupervisors ndef@Int64: #{ndef} Standardansprechpartner entfernt. 
 FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
 FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
 FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.
@@ -33,7 +37,8 @@ FirmUserActRemove: Firmenassoziation entfernen
 FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
 FirmUserActChangeDetailsResult n@Int64 t@Int64: Firmenassoziation von #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden aktualisiert
 FirmUserActChangeResult n@Int64 t@Int64: Benachrichtigungseinstellung für #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden geändert
-FirmuserActRemoveResult uc@Int64 sup@Int64 sub@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt. #{noneMoreDE sup "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöschtt. ")} #{noneMoreDE sub "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entfernten Angesprochenen gelöscht.")}
+FirmUserActRemoveResult uc@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt. 
+FirmRemoveSupervision sup@Int64 sub@Int64: #{noneMoreDE sup "" (tshow sup <> " Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöscht. ")} #{noneOneMoreDE sub "Keine Ansprechpartnerbeziehung" "Eine Ansprechpartnerbeziehung" (tshow sup <> " Ansprechpartnerbeziehungen")} wegen entferntem Angesprochenem gelöscht.
 FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen
 FirmSetSupervisor: Existierende Ansprechpartner hinzufügen
 FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)}
@@ -42,7 +47,7 @@ FirmSuperActNotify: Mitteilung versenden
 FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern
 FirmSuperActSwitchSuperInfo: Betrifft keine firmenfremden Ansprechpartner und ändert keine aktiven individuellen Ansprechpartnerbeziehungen. Gegebenfalls im Anschluss die Funktion "Ansprechpartner auf Firmenstandard zurücksetzen" nutzen.
 FirmSuperActRMSuperDef: Firmenansprechpartner entfernen
-FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden
+FirmSuperActRMSuperActive: Aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden?
 FirmsNotification: Firmen E-Mail versenden
 FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden
 FirmsNotificationTitle: Firmen benachrichtigen

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

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
+# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -15,11 +15,15 @@ FirmActionInfo: Affects alle company associates under your supervision.
 FirmActNotify: Send message
 FirmActResetSupervision: Reset supervisors for all company associates
 FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
+FirmActRemoveSupers: Terminate all company related supervisonships?
 FirmActResetMutualSupervision: Supervisors supervise each other
+FirmActResetSupersKeepAll: Keep all
+FirmActResetSupersRemoveAps: Remove default supervisors only
+FirmActResetSupersRemoveAll: Remove all
 FirmActAddSupervisors: Add supervisors
 FirmActAddSupersEmpty: No supervisors added
 FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
-RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but no active supervisions were deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}
+RemoveSupervisors ndef: #{ndef} default supervisors removed.
 FirmActChangeContactUser: Change contact data for all company associates
 FirmActChangeContactFirm: Change company contact data
 FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
@@ -33,7 +37,8 @@ FirmUserActRemove: Delete company association
 FirmUserActMkSuper: Mark as company supervisor
 FirmUserActChangeDetailsResult n t: #{n}/#{t} #{pluralENs n "company association"} updated
 FirmUserActChangeResult n t: Notification settings changed for #{n}/#{t} company #{pluralENs n "associate"}
-FirmuserActRemoveResult uc sup sub: #{pluralENsN uc "Company association"} deleted. #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "" ((pluralENsN sub "supervision") <> " removed due to eliminated supervisees.")}
+FirmUserActRemoveResult uc: #{pluralENsN uc "Company association"} deleted. 
+FirmRemoveSupervision sup sub: #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "No supervision" (pluralENsN sub "supervision")} removed due to eliminated supervisees.
 FirmNewSupervisor: Appoint new individual supervisors
 FirmSetSupervisor: Add existing supervisors
 FirmSetSupersReport nusr nspr nrem: #{nspr} individual supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
@@ -42,7 +47,7 @@ FirmSuperActNotify: Send message
 FirmSuperActSwitchSuper: Change default company supervisor
 FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individual supervisions. Additionally use reset action, if desired.
 FirmSuperActRMSuperDef: Remove default supervisor
-FirmSuperActRMSuperActive: Also remove active supervisions within this company
+FirmSuperActRMSuperActive: Terminate active supervisions within this company?
 FirmsNotification: Send company notification e-mail
 FirmNotification fsh: Send e-mail to #{fsh}
 FirmsNotificationTitle: Company notification

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

@@ -22,6 +22,7 @@ AdminUserPostAddress: Postalische Anschrift
 AdminUserPrefersPostal: Briefe anstatt Email bevorzugt
 AdminUserPinPassword: Passwort zur Verschlüsselung von PDF Anhängen in Emails
 AdminUserNoPassword: Kein Passwort gesetzt
+AdminUserPinPassNotIncluded: Hinweis: Das Passwort wird hier zur Bequemlichkeit zusätzlich angezeigt und ist selbstverständlich nicht im originalem Inhalt enthalten.
 AdminUserAssimilate: Diesen Benutzer assimilieren von
 UserAdded: Benutzer erfolgreich angelegt
 UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden

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

@@ -22,6 +22,7 @@ AdminUserPostAddress: Postal Address
 AdminUserPrefersPostal: Prefers postal letters over email
 AdminUserPinPassword: Password used for PDF attachments to emails
 AdminUserNoPassword: No password set
+AdminUserPinPassNotIncluded: Note: the password is shown here only for convenience, but is not contained in the original content, of course.
 AdminUserAssimilate: Assimilate user by another user
 UserAdded: Successfully added user
 UserCollision: Could not create user due to uniqueness constraint

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

@@ -153,6 +153,7 @@ MenuCommCenter: Benachrichtigungen
 MenuMailCenter: E‑Mails
 MenuMailHtml !ident-ok: Html
 MenuMailPlain !ident-ok: Text
+MenuMailAttachment: Anhang
 
 MenuApiDocs: API-Dokumentation (Englisch)
 MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)

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

@@ -153,6 +153,7 @@ MenuCommCenter: Notifications
 MenuMailCenter: Email
 MenuMailHtml: Html
 MenuMailPlain: Text
+MenuMailAttachment: Attachment
 
 MenuApiDocs: API documentation
 MenuSwagger: OpenAPI 2.0 (Swagger)

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

@@ -83,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hie
 AmbiguousEmail: E-Mail-Adresse nicht eindeutig
 InvalidEmailAddress: E-Mail-Adresse ist ungültig
 InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig
+MailFileAttachment: Dateianhang
 UtilExamResultGrade: Note
 UtilExamResultPass: Bestanden/Nicht Bestanden
 UtilExamResultNoShow: Nicht erschienen

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

@@ -83,6 +83,7 @@ MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email
 AmbiguousEmail: Email address is ambiguous
 InvalidEmailAddress: Email address is invalid
 InvalidEmailAddressWith e: Email asdress #{show e} is invalid
+MailFileAttachment: Attached file
 UtilExamResultGrade: Grade
 UtilExamResultPass: Passed/Failed
 UtilExamResultNoShow: Not present

nix/docker/version.json

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

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.77",
+  "version": "27.4.79",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.77",
+  "version": "27.4.79",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 27.4.77
+version: 27.4.79
 dependencies:
   - base
   - yesod

routes

@@ -82,6 +82,7 @@
 /comm/email                           MailCenterR     GET POST
 /comm/email/html/#CryptoUUIDSentMail  MailHtmlR       GET
 /comm/email/plain/#CryptoUUIDSentMail MailPlainR      GET
+/comm/email/attachment/#CryptoUUIDSentMail/#Text MailAttachmentR GET
 
 /print                                PrintCenterR    GET POST  !system-printer
 /print/acknowledge/#Day/#Int/#Int     PrintAckR       GET POST  !system-printer

src/Audit.hs

@@ -1,7 +1,9 @@
--- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# LANGUAGE TypeApplications #-}
+
 module Audit
   ( module Audit.Types
   , AuditException(..)
@@ -17,6 +19,8 @@ import Import.NoModel
 import Settings
 import Model
 import Database.Persist.Sql
+import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Utils        as E
 import Audit.Types
 
 import qualified Data.Text          as Text
@@ -129,7 +133,7 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User
       -> Text       -- ^ Any additional information
       -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
 -- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
-logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do 
+logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do
   interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
   logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo
 
@@ -173,20 +177,25 @@ logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogS
 
 reportAdminProblem ::  ( IsSqlBackend (YesodPersistBackend (HandlerSite m))
                   , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
-                  , MonadHandler m                 
+                  , MonadHandler m
                   -- , HasCallStack
                   )
-      => AdminProblem -- ^ Problem to record 
+      => AdminProblem -- ^ Problem to record
       -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
--- ^ Log a problem that needs interventions by admins 
+-- ^ Log a problem that needs interventions by admins, provided this problem has not already been reported and is still unsolved
 --
 --   - `problemLogTime` is now
 --   - `problemSolver` is Nothing, we do not record the person who caused it
-reportAdminProblem problem@(toJSON -> problemLogInfo) = do
-  problemLogTime <- liftIO getCurrentTime
+reportAdminProblem problem = do
   let problemLogSolved = Nothing
       problemLogSolver = Nothing
-  insert_ ProblemLog{..}
+      problemLogInfo   = toJSON problem
+  problemLogTime <- liftIO getCurrentTime
+  isKnown <- E.selectExists $ do
+    pl <- E.from $ E.table @ProblemLog
+    E.where_ $ E.isNothing (pl E.^. ProblemLogSolved)
+        E.&&. E.val problemLogInfo E.==. pl E.^. ProblemLogInfo
+  unless isKnown $ insert_ ProblemLog{..}
   $logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack)
 
 

src/Auth/Dummy.hs

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

src/Database/Esqueleto/Utils.hs

@@ -55,6 +55,7 @@ module Database.Esqueleto.Utils
   , day, day', dayMaybe, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
+  , psqlVersion_
   , truncateTable
   , module Database.Esqueleto.Utils.TH
   ) where
@@ -814,6 +815,8 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2
     ]
     (E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
 
+psqlVersion_ :: E.SqlExpr (E.Value Text)
+psqlVersion_ = E.unsafeSqlFunction "VERSION" ()
 
 -- Suspected to cause trouble. Needs more testing!
 -- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record)

src/Foundation/Navigation.hs

@@ -134,6 +134,7 @@ breadcrumb CommCenterR      = i18nCrumb MsgMenuCommCenter       Nothing
 breadcrumb MailCenterR      = i18nCrumb MsgMenuMailCenter     $ Just CommCenterR
 breadcrumb MailHtmlR{}      = i18nCrumb MsgMenuMailHtml       $ Just MailCenterR
 breadcrumb MailPlainR{}     = i18nCrumb MsgMenuMailPlain      $ Just MailCenterR
+breadcrumb (MailAttachmentR mid _) = i18nCrumb MsgMenuMailAttachment $ Just $ MailHtmlR mid
 
 breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc            $ Just CommCenterR
 breadcrumb PrintSendR       = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR

src/Handler/Admin/Avs.hs

@@ -266,33 +266,128 @@ postAdminAvsR = do
 
 
   (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
-  mbQryLic <- case qryLicRes of
-    Nothing -> return Nothing
+  (mbQryLic :: Maybe Widget, mbAutoDiffs :: Maybe Html) <- case qryLicRes of
+    Nothing -> return mempty
     (Just BtnCheckLicences) -> do
       res <- try $ do
         allLicences <- avsQueryNoCache AvsQueryGetAllLicences
         computeDifferingLicences allLicences
-      case res of
+      basediffs <- case res of
         (Right diffs) -> do
-          let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
-              r_grant = showLics AvsLicenceRollfeld
-              f_set   = showLics AvsLicenceVorfeld
-              revoke  = showLics AvsNoLicence
+          let showLics l =
+                let chgs = Set.filter ((l ==) . avsLicenceRampLicence) diffs
+                in if Set.null chgs
+                    then ("[ ]", 0)
+                    else (Text.intercalate ", " (tshow . avsLicencePersonID <$> Set.toList chgs), Set.size chgs)
+              (r_grant, rg_size) = showLics AvsLicenceRollfeld
+              (f_set  , fs_size) = showLics AvsLicenceVorfeld
+              (revoke , rv_size) = showLics AvsNoLicence
           return $ Just [whamlet|
-              <h2>Licence check differences:
-              <h3>Grant R:
-              <p>
-                #{r_grant}
-              <h3>Set to F:
-              <p>
-                #{f_set}
-              <h3>Revoke licence:
-              <p>
-                #{revoke}
+              <h2>Licence check AVS-ID differences:
+              <dl .deflist>
+                <dt .deflist__dt>Grant R (#{rg_size}):
+                <dd .deflist__dd>#{r_grant}
+
+                <dt .deflist__dt>Set to F (#{fs_size}):
+                <dd .deflist__dd>#{f_set}
+
+                <dt .deflist__dt>Revoke licence (#{rv_size}):
+                <dd .deflist__dd>#{revoke}
             |]
         (Left e) -> do
           let msg = tshow (e :: SomeException)
           return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
+      autoDiffs <- do
+        -- what follows is copy of the code from Jobs.Handler.SynchroniseAvs.dispatchJobSynchroniseAvsLicences modified to not do anything actually
+        AvsLicenceSynchConf
+          { avsLicenceSynchLevel        = synchLevel   -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
+          , avsLicenceSynchReasonFilter = reasonFilter
+          , avsLicenceSynchMaxChanges   = maxChanges
+          } <- getsYesod $ view _appAvsLicenceSynchConf
+        guardMonoidM (synchLevel > 0) $ do
+          let showApids apids
+                | null apids = "[ ]"
+                | otherwise = Text.intercalate ", " (tshow <$> Set.toList apids)
+              procLic :: (Ord a, Show a) => AvsLicence -> Bool -> Set a -> Html
+              procLic aLic up apids
+                | n <- Set.size apids, n > 0 =
+                  let subtype   = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
+                  in if NTop (Just n) <= NTop maxChanges
+                      then
+                        [shamlet|
+                          <dt .deflist__dt>#{subtype} (#{n}):
+                          <dd .deflist__dd>#{showApids apids}
+                        |]
+                      else
+                        [shamlet|
+                          <dt .deflist__dt>#{subtype} (#{n}):
+                          <dd .deflist__dd>Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}
+                        |]
+                | otherwise = mempty
+
+          (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
+          -- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
+          reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
+            now <- liftIO getCurrentTime
+            firmBlocks <- runDBRead $ E.select $ do
+              (uavs :& _qualUser :& qblock) <- X.from $ E.table @UserAvs
+                `E.innerJoin` E.table @QualificationUser      `X.on` (\( uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
+                `E.innerJoin` E.table @QualificationUserBlock `X.on` (\(_uavs :& qualUser :& qblock) ->
+                    qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
+                    E.&&. qblock `isLatestBlockBefore'` E.val now)
+              E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
+                    E.&&.  uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
+              return $ uavs E.^. UserAvsPersonId
+            return $ Set.fromList $ map E.unValue firmBlocks
+
+          let fltrIds
+                | synchLevel >= 5 = id
+                | synchLevel >= 3 = flip Set.difference   reasonFltrdIds
+                | otherwise       = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
+
+              l1 = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence       False $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
+              l2 = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld
+              l3 = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld  False $ fltrIds avsLicenceDiffRevokeRollfeld   --downgrade Rollfeld -> Vorfeld
+              l4 = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True  $ fltrIds avsLicenceDiffGrantRollfeld    --grant     Rollfeld
+              avsIdChanges = [shamlet|
+                  <h3>
+                    Next automatic AVS-ID licence synchronisation:
+                  <dl .deflist>
+                    ^{l4}
+                    ^{l3}
+                    ^{l2}
+                    ^{l1}
+                    $maybe reason <- reasonFilter
+                      <dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
+                      <dd .deflist__dd>#{showApids reasonFltrdIds}
+                |]
+          ----------------------------------------------------
+          -- translate AVS-IDs to AVS-NOs for convenience only
+          avsidnos <- runDBRead $ E.select $ do
+            ua <- X.from $ E.table @UserAvs
+            E.where_ $ ua E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld]) -- , reasonFltrdIds])
+            return (ua E.^. UserAvsPersonId, ua E.^. UserAvsNoPerson)
+          let id2no = Map.fromList $ $(E.unValueN 2) <$> avsidnos
+              translate = setMapMaybe (`Map.lookup` id2no)
+              l1' = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence       False $ translate $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
+              l2' = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ translate $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld
+              l3' = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld  False $ translate $ fltrIds avsLicenceDiffRevokeRollfeld   --downgrade Rollfeld -> Vorfeld
+              l4' = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True  $ translate $ fltrIds avsLicenceDiffGrantRollfeld    --grant     Rollfeld
+              autoNoDiffs =  [shamlet|
+                  <h3>
+                    Next automatic licence changes translated to human readable AVS-Numbers, if known:
+                  <dl .deflist>
+                    ^{l4'}
+                    ^{l3'}
+                    ^{l2'}
+                    ^{l1'}
+                    $maybe reason <- reasonFilter
+                      <dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
+                      <dd .deflist__dd>#{showApids $ translate reasonFltrdIds}
+                |]
+          return $ Just $ avsIdChanges <> autoNoDiffs
+      return (basediffs, autoDiffs)
+
     -- (Just BtnSynchLicences) -> do
     --   res <- try synchAvsLicences
     --   case res of

src/Handler/Admin/Test.hs

@@ -28,7 +28,9 @@ import Text.Hamlet
 -- import Handler.Utils.I18n
 
 import Handler.Admin.Test.Download (testDownload)
-
+import qualified Database.Esqueleto.Experimental as E (selectOne, unValue)
+import qualified Database.Esqueleto.PostgreSQL as E  (now_)
+import qualified Database.Esqueleto.Utils as E (psqlVersion_)
 
 -- BEGIN - Buttons needed only here
 data ButtonCreate = CreateMath | CreateInf | CrashApp -- Dummy for Example
@@ -226,6 +228,9 @@ postAdminTestR = do
 
   UniWorX{ appSettings' = AppSettings{..} } <- getYesod
 
+  psqlVersion <- runDBRead $ E.selectOne $ return E.psqlVersion_
+  dbTime      <- runDBRead $ E.selectOne $ return E.now_
+
   let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
   siteLayout locallyDefinedPageHeading $ do
   -- defaultLayout $ do
@@ -327,6 +332,17 @@ postAdminTestR = do
           <dd .deflist__dd>#{tshow appSynchroniseAvsUsersWithin}
     |]
 
+    [whamlet|
+      <section>
+        <h2> PostgreSQL Information
+        <dl .deflist>
+          $maybe pver <- psqlVersion
+            <dt .deflist__dt>DB Version
+            <dd .deflist__dd>#{E.unValue pver}
+          $maybe ptme <- dbTime
+            <dt .deflist__dt>DB Time
+            <dd .deflist__dd>#{tshow (E.unValue ptme)}
+    |]
 
 
 

src/Handler/Firm.hs

@@ -742,29 +742,28 @@ embedRenderMessage ''UniWorX ''FirmUserAction id
 
 data FirmUserActionData = FirmUserActNotifyData
                         | FirmUserActResetSupervisionData
-                            { firmUserActResetKeepOldSupers     :: Maybe Bool
-                            -- , firmUserActResetMutualSupervision :: Maybe Bool
+                            { firmUserActResetSupers            :: Maybe Bool
                             }
                         | FirmUserActSetSupervisorData
-                            {  firmUserActSetSuperNames   :: Maybe (Set Text)
-                            ,  firmUserActSetSuperIds     :: Maybe [UserId]
-                            ,  firmUserActSetSuperReason  :: Maybe Text
-                            ,  firmUserActSetSuperReroute :: Bool
-                            ,  firmUserActSetSuperKeep    :: Bool
+                            { firmUserActSetSuperNames          :: Maybe (Set Text)
+                            , firmUserActSetSuperIds            :: Maybe [UserId]
+                            , firmUserActSetSuperReason         :: Maybe Text
+                            , firmUserActSetSuperReroute        :: Bool
+                            , firmUserActResetSupers            :: Maybe Bool
                             }
                         | FirmUserActMkSuperData
-                            { firmUserActMkSuperReroute   :: Maybe Bool }
+                            { firmUserActMkSuperReroute         :: Maybe Bool }
                         | FirmUserActChangeDetailsData
-                            { firmUserActDetailPriority     :: Maybe Int
-                            , firmUserActDetailReason       :: Maybe Text
+                            { firmUserActDetailPriority         :: Maybe Int
+                            , firmUserActDetailReason           :: Maybe Text
                             }
                         | FirmUserActChangeContactData
-                            { firmUserActPostalAddr         :: Maybe StoredMarkup
-                            , firmUserActUseCompanyPostal   :: Maybe Bool
-                            , firmUserActPostalPref         :: Maybe Bool
+                            { firmUserActPostalAddr             :: Maybe StoredMarkup
+                            , firmUserActUseCompanyPostal       :: Maybe Bool
+                            , firmUserActPostalPref             :: Maybe Bool
                             }
                         | FirmUserActRemoveData
-                            { firmUserActRemoveKeepSuper :: Bool
+                            { firmUserActRemoveSupers           :: Bool
                             }
   deriving (Eq, Ord, Show, Generic)
 
@@ -968,25 +967,24 @@ mkFirmUserTable isAdmin cid = do
         acts = mconcat
           [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
           , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
-              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)         (Just $ Just False)
-              -- <*> aopt checkBoxField                                      (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
+              <$> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
           , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
               <$> aopt (textField & cfAnySeparatedSet)                    (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
               <*> aopt supervisorsField                                   (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip)                          Nothing
-              <*> aopt (textField & cfStrip & addDatalist superReasons)   (fslI MsgUserSupervisorReason  & setTooltip MsgUserSupervisorReasonTooltip)          Nothing
-              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
-              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                                                     (Just False)
+              <*> aopt (textField & cfStrip & addDatalist superReasons)   (fslI MsgUserSupervisorReason  & setTooltip MsgUserSupervisorReasonTooltip)         Nothing
+              <*> areq  boolField'                                        (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
+              <*> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
           , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
               <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
-          , singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData
-              <$> aopt intField                                           (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
-              <*> aopt (textField & cfStrip & addDatalist userReasons)    (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
           , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
               <$> aopt htmlField        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
               <*> aopt boolField'       (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
               <*> aopt postalEmailField (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
+          , singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData
+              <$> aopt intField                                           (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
+              <*> aopt (textField & cfStrip & addDatalist userReasons)    (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
           , singletonMap FirmUserActRemove $ FirmUserActRemoveData
-              <$> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                                                     (Just False)
+              <$> areq boolField'       (fslI MsgFirmActRemoveSupers) (Just True)
           ]
         dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
@@ -1053,6 +1051,10 @@ postFirmUsersR fsh = do
       --     return usr
       <*> mkFirmUserTable isAdmin cid
 
+  let resetSupers :: Maybe Bool -> NonEmpty UserId -> DB Int64
+      resetSupers Nothing      _    = return 0
+      resetSupers (Just False) uids = deleteDefaultSupervisorsForUsers [] [] uids
+      resetSupers (Just True ) uids = deleteWhereCount [UserSupervisorUser <-. toList uids]
   formResult fusrRes $ \case
     (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
     (FirmUserActNotifyData , uids) -> do
@@ -1060,9 +1062,7 @@ postFirmUsersR fsh = do
       redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
     (FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do  -- set guaranteed to be non-empty due to first case clause
       runDB $ do
-        delSupers <- if firmUserActResetKeepOldSupers == Just False
-          then deleteDefaultSupervisorsForUsers [] [] uids
-          else return 0
+        delSupers <- resetSupers firmUserActResetSupers uids
         newSupers <- addDefaultSupervisors Nothing cid uids
         addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
@@ -1081,8 +1081,7 @@ postFirmUsersR fsh = do
                   <li>#{usr}
               |]
         in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
-      delSupers <- runDB
-         $ bool (deleteDefaultSupervisorsForUsers [cid] [] uids) (return 0) firmUserActSetSuperKeep
+      delSupers <- runDB $ resetSupers firmUserActResetSupers uids
         <* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) firmUserActSetSuperReason | u <- toList uids, s <- newSupers]
       addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
@@ -1119,11 +1118,15 @@ postFirmUsersR fsh = do
             allok = bool Warning Success $ nrChanged == total
         addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
         reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
-    (FirmUserActRemoveData{}, Set.toList -> uids) -> do
-      (nrUc, nrSuper, nrSubs) <- runDB $ deleteCompanyUser cid uids
+    (FirmUserActRemoveData{..}, Set.toList -> uids) -> do
+      let optRemove = if firmUserActRemoveSupers then id else const $ return 0
+      (nrUc, nrSuper, nrSubs) <- runDB $ (,,)
+        <$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser       <-. uids])
       let total = fromIntegral $ length uids
-          allok = bool Warning Success $ nrUc == total
-      addMessageI allok $ MsgFirmuserActRemoveResult nrUc nrSuper nrSubs
+          allok = bool Warning Success $ total == nrUc
+      addMessageI allok $ someMessages [MsgFirmUserActRemoveResult nrUc, MsgFirmRemoveSupervision nrSuper nrSubs]
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
 
   formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
@@ -1153,7 +1156,7 @@ data FirmSuperActionData = FirmSuperActNotifyData
                             , firmSuperActSwitchReroute :: Maybe Bool
                             }
                          | FirmSuperActRMSuperDefData
-                            { firmSuperActRMSuperActive :: Maybe Bool }
+                            { firmSuperActRMSuperActive ::       Bool }
 
   deriving (Eq, Ord, Show, Generic)
 
@@ -1296,11 +1299,11 @@ mkFirmSuperTable isAdmin cid = do
         acts = mconcat
           [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
           , singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData
-              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperDefault)  (Just $ Just True)
-              <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute)      Nothing
+              <$> aopt boolField' (fslI MsgFirmSuperDefault)  (Just $ Just True)
+              <*> aopt boolField' (fslI MsgTableIsDefaultReroute)      Nothing
               <*  aformMessage msgSupervisorUnchanged
           , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
-              <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
+              <$> areq boolField' (fslI MsgFirmSuperActRMSuperActive) (Just True)
           ]
         dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
@@ -1344,19 +1347,14 @@ postFirmSupersR fsh = do
   formResult fsprRes $ \case
     (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
     (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
-      (nrRmSuper,nrRmActual) <- runDB $ (,)
+      let optRemove = if firmSuperActRMSuperActive then id else const $ return 0
+      (nrRmSuper,nrRmSupers,nrRmSubs) <- runDB $ (,,)
         <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
-        <*> if firmSuperActRMSuperActive /= Just True
-              then return 0
-              else E.deleteCount $ do
-                spr <- E.from $ E.table @UserSupervisor
-                E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids
-                    E.&&. E.exists (do
-                      usr <- E.from $ E.table @UserCompany
-                      E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
-                          E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
-                    )
-      addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
+        <*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser       <-. uids])
+      let total = fromIntegral $ length uids
+          allok = bool Warning Success $ total == nrRmSuper
+      addMessageI allok $ someMessages [MsgRemoveSupervisors nrRmSuper, MsgFirmRemoveSupervision nrRmSupers nrRmSubs]
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
     (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do
       let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of

src/Handler/Health.hs

@@ -20,6 +20,9 @@ import Control.Concurrent.STM.Delay
 
 import System.Environment (lookupEnv) -- while git version number is not working
 
+import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.PostgreSQL as E  (now_)
+
 -- import Data.FileEmbed (embedStringFile)
 
 getHealthR :: Handler TypedContent
@@ -114,10 +117,16 @@ getInstanceR = do
 getStatusR :: Handler Html
 getStatusR = do
   starttime <- getsYesod appStartTime
-  (currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
+  dbTime <- runDBRead $ E.selectOne $ return E.now_
+  (currtime,env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
   -- ft <- formatTime'  "%Y-%m-%d %H:%M:%S" currtime
   let diffTime :: UTCTime -> Text
-      diffTime = pack . iso8601Show . calendarTimeTime . fromIntegral . truncate . diffUTCTime currtime
+      diffTime t =
+        let tdiff = diffUTCTime currtime t
+        in if 64 > abs tdiff
+            then tshow tdiff
+            else pack . iso8601Show . calendarTimeTime . fromIntegral $ truncate tdiff
+
   withUrlRenderer
     [hamlet|
       $doctype 5
@@ -129,8 +138,13 @@ getStatusR = do
             <p>
               Environment version #{env_ver}
           <p>
-            Current Time <br>
+            Current Application Time <br>
             #{show currtime} <br>
+          $maybe dbtval <- dbTime
+            $with dbt <- E.unValue dbtval
+              Current Database Time <br>
+              #{show dbt} #
+              Difference: #{diffTime dbt} <br>
           <p>
             Instance Start <br>
             #{show starttime} #

src/Handler/MailCenter.hs

@@ -8,6 +8,7 @@ module Handler.MailCenter
   ( getMailCenterR, postMailCenterR
   , getMailHtmlR
   , getMailPlainR
+  , getMailAttachmentR
   ) where
 
 import Import
@@ -163,6 +164,27 @@ postMailCenterR = do
     $(widgetFile "mail-center")
 
 
+typePDF :: ContentType
+typePDF = "application/pdf"
+
+getMailAttachmentR :: CryptoUUIDSentMail -> Text -> Handler TypedContent
+getMailAttachmentR cusm attdisp = do
+  smid <- decrypt cusm
+  (sm,cn) <- runDBRead $ do
+    sm <- get404 smid
+    cn <- get404 $ sm ^. _sentMailContentRef
+    return (sm,cn)
+  let mcontent = getMailContent (sentMailContentContent cn)
+      getAttm alts = case selectAlternative [typePDF] alts of
+        (Just Part{partContent=PartContent (LB.toStrict -> pc), partDisposition=AttachmentDisposition t}) -- partType=pt,
+          | t == attdisp
+            -> Just pc
+        _ -> Nothing
+      attm = firstJust getAttm mcontent
+  case attm of
+    (Just pc) -> sendByteStringAsFile (T.unpack attdisp) pc $ sm ^. _sentMailSentAt
+    _              -> notFound
+
 getMailHtmlR  :: CryptoUUIDSentMail -> Handler Html
 getMailHtmlR  = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml])  [typeHtml,typePlain]
 
@@ -180,6 +202,7 @@ handleMailShow hdr prefTypes cusm = do
     setTitleI hdr
     let mcontent = getMailContent (sentMailContentContent cn)
         getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
+        mparts = reorderParts $ mapMaybe (selectAlternative prefTypes) mcontent
     [whamlet|
       <section>
         <dl .deflist>
@@ -214,10 +237,8 @@ handleMailShow hdr prefTypes cusm = do
               #{decodeEncodedWord r}
 
       <section>
-        $forall mc <- mcontent
-          $maybe pt <- selectAlternative prefTypes mc
-            <p>
-              ^{part2widget pt}
+        $forall pt <- mparts
+          ^{part2widget cusm pt}
     |]
       -- Include for Debugging:
       -- <section>
@@ -237,24 +258,36 @@ selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
     aux []     (pt:_)     = Just pt
     aux _      []         = Nothing
 
+reorderParts :: [Part] -> [Part]
+reorderParts = sortBy pOrder
+  where
+    pOrder Part{partDisposition=d1} Part{partDisposition=d2} = dispoOrder d1 d2
+
+    dispoOrder DefaultDisposition DefaultDisposition                 = EQ
+    dispoOrder DefaultDisposition _                                  = LT
+    dispoOrder _ DefaultDisposition                                  = GT
+    dispoOrder (InlineDisposition t1) (InlineDisposition t2)         = compare t1 t2
+    dispoOrder (InlineDisposition _) _                               = LT
+    dispoOrder _ (InlineDisposition _)                               = GT
+    dispoOrder (AttachmentDisposition t1) (AttachmentDisposition t2) = compare t1 t2
+
 disposition2widget :: Disposition -> Widget
-disposition2widget (AttachmentDisposition n) = [whamlet|<h3>Attachment #{n}|]
-disposition2widget (InlineDisposition     n) = [whamlet|<h3>#{n}|]
+disposition2widget (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
+disposition2widget (InlineDisposition     n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
 disposition2widget  DefaultDisposition       = mempty
 
-part2widget :: Part -> Widget
-part2widget Part{partContent=NestedParts ps} =
+part2widget :: CryptoUUIDSentMail -> Part -> Widget
+part2widget cusm Part{partContent=NestedParts ps} =
   [whamlet|
-    <section>
       $forall p <- ps
-        <p>
-          ^{part2widget p}
+        ^{part2widget cusm p}
   |]
-part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
+part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
     [whamlet|
       <section>
         ^{disposition2widget dispo}
         ^{showBody}
+      ^{showPass}
     |]
   where
     showBody
@@ -263,8 +296,38 @@ part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partD
       | pt == decodeUtf8 typeJson  =
           let jw :: Aeson.Value -> Widget = jsonWidget
           in  either str2widget jw $ Aeson.eitherDecodeStrict' pc
-      | otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]
-
+      | pt == decodeUtf8 typePDF
+      , AttachmentDisposition t <- dispo
+        = [whamlet|<a href=@{MailAttachmentR cusm t}>#{t}|]
+      | otherwise = [whamlet|FRADrive cannot decode email parts of type #{pt} yet.|]
+    showPass
+      | pt == decodeUtf8 typePlain
+      , let cw = T.words $ decodeUtf8 pc
+      , Just name <- listBracket ("Inhaber","Gültig") cw                               -- heursitic for dirving licence renewal letters only; improve
+                <|>  listBracket ("Licensee","Valid") cw
+      = let sdn = T.filter (/= '*') (T.unwords $ dropWhile (":"==) name) in
+        liftHandler (runDBRead $ getByFilter [UserDisplayName ==. sdn]) >>= \case
+          Nothing -> mempty -- DEBUG: [whamlet|<h2>Not found: #{sdn}|]
+          Just Entity{entityVal = u@User{userPinPassword=mbpw}} ->
+            [whamlet|
+              <section>
+                $maybe pw <- mbpw
+                  <details>
+                    <summary>
+                      _{MsgAdminUserPinPassword}
+                    <p>
+                      <dl .deflist>
+                        <dt .deflist__dt>
+                          ^{userWidget u}
+                        <dd .deflist__dd>
+                          <b>
+                            #{pw}
+                    <p>
+                      _{MsgAdminUserPinPassNotIncluded}
+                $nothing
+                  _{MsgAdminUserNoPassword}
+            |]
+      | otherwise = mempty
 
 ------------------------------
 -- Decode MIME Encoded Word

src/Handler/Qualification.hs

@@ -96,12 +96,12 @@ mkQualificationAllTable isAdmin = do
               maybeCell (qualificationDescription quali) markupCellLargeModal
           , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
               foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
+          , sortable Nothing (i18nCell MsgQualificationRefreshWithin    & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip  , SomeMessage MsgTableDiffDaysTooltip]) $
+              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshWithin)
           , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row ->
               let elearnstart = row ^. resultAllQualification . _qualificationElearningStart
                   reminder    = row ^. resultAllQualification . _qualificationRefreshReminder
               in tickmarkCell $ elearnstart && isJust reminder
-          , sortable Nothing (i18nCell MsgQualificationRefreshWithin    & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip  , SomeMessage MsgTableDiffDaysTooltip]) $
-              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshWithin)
           , sortable Nothing (i18nCell MsgQualificationRefreshReminder  & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
               foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshReminder)
           , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
@@ -543,7 +543,7 @@ postQualificationR sid qsh = do
           Ex.groupBy     (qblock Ex.^. QualificationUserBlockReason)
           let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows
           Ex.orderBy [Ex.desc countRows']
-          Ex.limit 7
+          Ex.limit 9
           pure (qblock Ex.^. QualificationUserBlockReason)
         mkOption :: Ex.Value Text -> Option Text
         mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }

src/Handler/Users.hs

@@ -191,18 +191,19 @@ postUsersR = do
         fmap (setOf $ folded . _Value . _Just) . Ex.select . Ex.distinct $ do
           usrc <- Ex.from $ Ex.table @UserSupervisor
           E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
+          Ex.limit 9
           return $ usrc E.^. UserSupervisorReason
       acts :: Map UserAction (AForm Handler UserActionData)
       acts = mconcat
         [ singletonMap UserLdapSync      $ pure UserLdapSyncData
         , singletonMap UserAvsSync       $ pure UserAvsSyncData
         , singletonMap UserAddSupervisor $ UserAddSupervisorData
-            <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
-            <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
+            <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor       & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)     Nothing
+            <*> apopt  boolField'                     (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)                (Just False)
             <*> aopt  (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
         , singletonMap UserSetSupervisor $ UserSetSupervisorData
-            <$> apopt  (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
-            <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
+            <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor       & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)     Nothing
+            <*> apopt  boolField'                     (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)                (Just False)
             <*> aopt  (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
         , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
         , singletonMap UserRemoveSubordinates $ pure UserRemoveSubordinatesData

src/Handler/Utils/Avs.hs

@@ -329,6 +329,8 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
       let usrId = userAvsUser usravs
       usr <- MaybeT $ get usrId
       lift $ do -- maybeT no longer needed from here onwards
+        uuid :: CryptoUUIDUser <- encrypt usrId
+        $logInfoS "AVS" [st|updateAvsUserByADC: #{tshow uuid}|]
         let oldAvsPersonInfo  = userAvsLastPersonInfo usravs   -- Nothing is ok here
             oldAvsFirmInfo    = userAvsLastFirmInfo   usravs   -- Nothing is ok here
             oldAvsCardNo      = userAvsLastCardNo     usravs & fmap Just
@@ -380,71 +382,73 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
                       , UserAvsLastCardNo     =. newAvsCardNo
                       ]
 
-        -- update company association & supervision
-        Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
-        oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
-        primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
-        let oldCompanyId = entityKey <$> oldCompanyEnt
-            -- oldCompanyMb = entityVal <$> oldCompanyEnt
-            -- pst_up  = if
-            --           -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId                                              -- refactor could replace next 4 lines
-            --           --   -> mkUpdate'      usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
-            --           | isNothing oldCompanyMb
-            --             -> mkUpdateDirect usr newCompany              $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
-            --           | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
-            --             -> mkUpdate       usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- possibly change postal preference
-            --           | otherwise
-            --             -> Nothing
-            superReasonComDef = tshow SupervisorReasonCompanyDefault
-            newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
+        usr_up2 <- guardMonoidM (oldAvsFirmInfo /= Just newAvsFirmInfo) $ do
+          -- update company association & supervision
+          newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
+          upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId   -- ensure firmInfo superior is supervisor for this user
+          oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
+          primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
+          let oldCompanyId = entityKey <$> oldCompanyEnt
+              -- oldCompanyMb = entityVal <$> oldCompanyEnt
+              -- pst_up  = if
+              --           -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId                                              -- refactor could replace next 4 lines
+              --           --   -> mkUpdate'      usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
+              --           | isNothing oldCompanyMb
+              --             -> mkUpdateDirect usr newCompany              $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
+              --           | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
+              --             -> mkUpdate       usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- possibly change postal preference
+              --           | otherwise
+              --             -> Nothing
+              superReasonComDef = tshow SupervisorReasonCompanyDefault
+              newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
 
-        usr_up2 <- case oldAvsFirmInfo of
-          _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
-              -> return mempty                                                                --  => do nothing
-          (Just oafi) |  isJust    (view _avsFirmPostAddressSimple  oafi)
-                      && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo       -- non-empty company address unchanged OR
-                      || isJust    (view _avsFirmPrimaryEmail       oafi)
-                      && ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo       -- non-empty company primary email unchanged
-              -> do                                                                           --  => just update user company association, keeping supervision privileges
-                  case oldCompanyId of
-                    Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
-                    Just ocid -> do
-                      void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId)  -- keep default supervisor settings
-                      void $ updateWhere [ UserSupervisorSupervisor ==. usrId                                               -- update company-related supervisions
-                                         , UserSupervisorCompany ==. Just ocid                                              -- to new company, regardless of
-                                         , UserSupervisorReason ==. Just superReasonComDef]                                 -- user
-                                         [ UserSupervisorCompany =. Just newCompanyId]
-                  return mempty
-          _ | Just newCompanyId == primaryCompanyId                                           -- old primaryCompany is now also AVS-company
-              -> do
-                  whenIsJust oldCompanyId $ \oldCid -> do
-                    deleteBy $ UniqueUserCompany usrId oldCid
-                    deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
-                  return mempty
-          _                                                                                   -- company changed completely
-              -> do
-                  (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
-                  mapM_ reportAdminProblem problems
-                  -- Following line does not type, hence additional parameter needed
-                  -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
-                  return pst_up
-                  -- SPECIALISED CODE, PROBABLY DEPRECATED
-                  -- switch user company, keeping old priority
-                  -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
-                  --   Nothing ->
-                  --     void $ insertUnique newUserComp
-                  --   Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
-                  --     when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
-                  --     delete ucidOld
-                  --     void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
-                  -- -- adjust supervison
-                  -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
-                  -- deleteWhere $          (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
-                  -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
-                  -- addDefaultSupervisors' newCompanyId $ singleton usrId
-                  -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
-                  -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
-                  -- return pst_up
+          case oldAvsFirmInfo of
+            _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
+                -> return mempty                                                                --  => do nothing
+            (Just oafi) |  isJust    (view _avsFirmPostAddressSimple  oafi)
+                        && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo       -- non-empty company address unchanged OR
+                        || isJust    (view _avsFirmPrimaryEmail       oafi)
+                        && ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo       -- non-empty company primary email unchanged
+                -> do                                                                           --  => just update user company association, keeping supervision privileges
+                    case oldCompanyId of
+                      Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
+                      Just ocid -> do
+                        void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId)  -- keep default supervisor settings
+                        void $ updateWhere [ UserSupervisorSupervisor ==. usrId                                               -- update company-related supervisions
+                                          , UserSupervisorCompany ==. Just ocid                                              -- to new company, regardless of
+                                          , UserSupervisorReason ==. Just superReasonComDef]                                 -- user
+                                          [ UserSupervisorCompany =. Just newCompanyId]
+                    return mempty
+            _ | Just newCompanyId == primaryCompanyId                                           -- old primaryCompany is now also AVS-company
+                -> do
+                    whenIsJust oldCompanyId $ \oldCid -> do
+                      deleteBy $ UniqueUserCompany usrId oldCid
+                      deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
+                    return mempty
+            _                                                                                   -- company changed completely
+                -> do
+                    (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
+                    mapM_ reportAdminProblem problems
+                    -- Following line does not type, hence additional parameter needed
+                    -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
+                    return pst_up
+                    -- SPECIALISED CODE, PROBABLY DEPRECATED
+                    -- switch user company, keeping old priority
+                    -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
+                    --   Nothing ->
+                    --     void $ insertUnique newUserComp
+                    --   Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
+                    --     when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
+                    --     delete ucidOld
+                    --     void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
+                    -- -- adjust supervison
+                    -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
+                    -- deleteWhere $          (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
+                    -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
+                    -- addDefaultSupervisors' newCompanyId $ singleton usrId
+                    -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
+                    -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
+                    -- return pst_up
         update usrId usr_up2                                         -- update user by company switch first (due to possible conflicts with usr_up2)
         update usrId usr_up1                                         -- update user eventually
         update uaId  avs_ups                                         -- update stored avsinfo for future updates
@@ -584,16 +588,18 @@ getAvsCompany afi =
 
 -- | insert a company from AVS firm info or update an existing one based on previous values
 upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
+-- upsertAvsCompany newAvsFirmInfo (Just oldAvsFirmInfo)
+--   | newAvsFirmInfo == oldAvsFirmInfo = maybeM (upsertAvsCompany newAvsFirmInfo Nothing) pure $ getAvsCompany newAvsFirmInfo  -- firmInfo unchanged, shortcircuit; SHORTCIRCUIT no longer needed, checked at call-site due to result not being wrapped in Maybe
 upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
     mbFirmEnt <- getAvsCompany newAvsFirmInfo --  primarily by AvsId, then Shorthand, then name
-    $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
-    cmpEnt <- case (mbFirmEnt, mbOldAvsFirmInfo) of
-      (Nothing, _) -> do                                                                                  -- insert new company, neither AvsId nor Shorthand exist in DB
+    $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbOldAvsFirmInfo} new #{tshow newAvsFirmInfo} ent-new #{tshow mbFirmEnt}|]
+    case mbFirmEnt of
+      Nothing -> do                                                                                  -- insert new company, neither AvsId nor Shorthand exist in DB
         afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
                 then return $ newAvsFirmInfo ^. _avsFirmFirmNo
                 else maybe (-1) (pred . companyAvsId . entityVal) <$> selectMaybe [CompanyAvsId <. 0] [Asc CompanyAvsId]
         let upd  = flip updateRecord newAvsFirmInfo
-            dmy = Company                                                                                 -- mostly dummy, values are actually prodcued through firmInfo2company below for consistency
+            dmy = Company                                                                            -- mostly dummy, values are actually produced through firmInfo2company below for consistency
                   { companyName           = newAvsFirmInfo ^. _avsFirmFirm          . from _CI
                   , companyShorthand      = newAvsFirmInfo ^. _avsFirmAbbreviation  . from _CI
                   , companyAvsId          = afn
@@ -605,11 +611,12 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
         $logInfoS "AVS" $ "Insert new company: " <> tshow cmp
         newCmp <- insertEntity cmp
         reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
-        $logInfoS "AVS" "Insert new company completed."
         return newCmp
 
-      (Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do                               -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
-        let cmp_ups = mapMaybe  (mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
+      (Just Entity{entityKey=firmid, entityVal=firm}) -> do                                          -- possibly update existing company, if isJust oldAvsFirmInfo and identical AvsFirmNo and changes occurred
+        let oldHasSameFirmNo = Just (newAvsFirmInfo ^. _avsFirmFirmNo) == (mbOldAvsFirmInfo ^? _Just . _avsFirmFirmNo)
+            oldAvsFirmInfo = guardOnM oldHasSameFirmNo mbOldAvsFirmInfo
+            cmp_ups = mapMaybe  (mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
             key_ups =            mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo  firmInfo2key
         uniq_ups    <-           mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo  firmInfo2companyNo
         $logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow oldAvsFirmInfo}|]
@@ -628,10 +635,8 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
                | otherwise -> $logInfoS "AVS" $ "Update company shorthand failed for " <> ciOriginal cmp_key <> " and " <> ciOriginal alt_key
             maybeM (return res_cmp) return $ getBy uniq_cmp
           _otherwise -> return res_cmp
-        $logInfoS "AVS" "Update company completed."
+        $logInfoS "AVS" [st|Update company #{companyShorthand firm} completed.|]
         return res_cmp2
-    void $ upsertCompanySuperior cmpEnt newAvsFirmInfo mbOldAvsFirmInfo                -- ensure firmInfo superior is supervisor
-    return cmpEnt
   where
     firmInfo2key =
         CheckUpdate CompanyShorthand   $ _avsFirmAbbreviation  . from _CI  -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
@@ -644,9 +649,10 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
       -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal          -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
       ]
 
--- upsert company supervisor from AvsFirmEMailSuperior
-upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> DB () -- (Maybe UserId) possibly return superior, but currently not needed
-upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi = do
+
+-- | adjust superiors, assumes that CompanyUser exists for all usrs for given company; does not work otherwise
+upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> UserId -> DB () -- may return superior (Maybe UserId), but currently not needed
+upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrId =
   let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
       getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
       newAvsNo    = newAfi ^.         _avsFirmFirmNo
@@ -655,51 +661,61 @@ upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi =
       mbOldEmail  = oldAfi ^? _Just . _avsFirmEMailSuperior . _Just
       getSupId    =  getInsertUid                `traverseJoin` mbSupEmail
       getOldId    = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail
-      unchangedCompany  = oldAvsNo   == Just newAvsNo
-      changedSuperior   = mbSupEmail /= mbOldEmail     -- beware, both could be Nothing
-  mbSupId <- getSupId
-  -- delete old superiors, if any
-  when (unchangedCompany && changedSuperior) $
-    deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
-                        [ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
-  -- ensure superior supervision
-  case mbSupId of
-    Just supId -> do
-      -- ensure association between company and superior at equal-to-top priority
-      prio <- getCompanyUserMaxPrio supId
-      void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
-      -- ensure all company associates are irregularly supervised by the superior
-      E.insertSelectWithConflict UniqueUserSupervisor
-        (do
-          usr <- E.from $ E.table @UserCompany
-          E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
-              -- E.&&. E.notExists (do                                                              -- restrict to primary company only
-              --     othr <- E.from $ E.table @UserCompany
-              --     E.where_ $ othr E.^. UserCompanyPriority E.>.  usr E.^. UserCompanyPriority
-              --         E.&&.  othr E.^. UserCompanyUser     E.==. usr E.^. UserCompanyUser
-              --         E.&&.  othr E.^. UserCompanyCompany  E.!=. E.val cid                       -- redundant due to > above, but likely performance improving
-              --   )
-          return $ UserSupervisor
-            E.<#  E.val supId
-            E.<&> (usr E.^. UserCompanyUser)
-            E.<&> E.false
-            E.<&> E.justVal cid
-            E.<&> E.val reasonSuperior
-        )
-        (\_old _new -> [] -- do not change exisitng supervision
-          -- [ UserSupervisorCompany               E.=. new E.^. UserSupervisorCompany
-          -- , UserSupervisorReason                E.=. new E.^. UserSupervisorReason
-          -- , UserSupervisorRerouteNotifications  E.=. new E.^. UserSupervisorRerouteNotifications
-          -- ]
-        )
-      when (unchangedCompany && changedSuperior) $ do
-        oldSupId <- getOldId
-        reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
-    Nothing ->
-      when (unchangedCompany && changedSuperior) $ do
-        oldSupId <- getOldId
-        reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
+      getSupervision :: Maybe UserId -> DB (Maybe (Entity UserSupervisor))
+      getSupervision = traverseJoin (getBy . flip UniqueUserSupervisor usrId)
+      unchangedCompany = oldAvsNo   == Just newAvsNo
+      changedSuperior  = mbSupEmail /= mbOldEmail     -- beware we only have AvsFirmInfo for one user; also both could be Nothing
+      --   1. not unchangedCompany: do not delete, but ensure that superior supervision is set, since it could be a just a single user company change
+      --   2. unchangedCompany && not changedSuperior: superior must already been set, short-circuit
+      --   3. unchangedCompany && changedSuperior: update superior for all users
+  in unless (unchangedCompany && not changedSuperior) $ do      -- do nothing if (unchangedCompany && not changedSuperior).
+    mbSupId  <- getSupId
+    mbUsrSup <- getSupervision mbSupId
+    -- delete old superiors, if any
+    when (unchangedCompany && changedSuperior) $
+      deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
+                          [ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
+    unless unchangedCompany $
+      deleteWhere [ UserSupervisorReason ==. reasonSuperior, UserSupervisorUser ==. usrId ]
+    -- ensure superior supervision
+    case (mbSupId, mbUsrSup) of
+      (_          , Just _) -> return () -- supId is already supervisor for uid for any reason
+      (Just supId, Nothing) -> do
+        -- ensure association between company and superior at equal-to-top priority
+        prio <- getCompanyUserMaxPrio supId
+        void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
 
+        -- ensure all company associates are irregularly supervised by the superior
+        E.insertSelectWithConflict UniqueUserSupervisor
+          (do
+            usr <- E.from $ E.table @UserCompany
+            E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
+                -- E.&&. E.notExists (do                                                              -- restrict to primary company only
+                --     othr <- E.from $ E.table @UserCompany
+                --     E.where_ $ othr E.^. UserCompanyPriority E.>.  usr E.^. UserCompanyPriority
+                --         E.&&.  othr E.^. UserCompanyUser     E.==. usr E.^. UserCompanyUser
+                --         E.&&.  othr E.^. UserCompanyCompany  E.!=. E.val cid                       -- redundant due to > above, but likely performance improving
+                --   )
+            return $ UserSupervisor
+              E.<#  E.val supId
+              E.<&> (usr E.^. UserCompanyUser)
+              E.<&> E.false
+              E.<&> E.justVal cid
+              E.<&> E.val reasonSuperior
+          )
+          (\_old _new -> [] -- do not change exisitng supervision
+            -- [ UserSupervisorCompany               E.=. new E.^. UserSupervisorCompany
+            -- , UserSupervisorReason                E.=. new E.^. UserSupervisorReason
+            -- , UserSupervisorRerouteNotifications  E.=. new E.^. UserSupervisorRerouteNotifications
+            -- ]
+          )
+        when (unchangedCompany && changedSuperior) $ do
+          oldSupId <- getOldId
+          reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
+      (Nothing, Nothing) ->
+        when (unchangedCompany && changedSuperior) $ do
+          oldSupId <- getOldId
+          reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
 
 queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64
 queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User)    (E.^. UserId)      (\usr    -> usr E.^. UserId             `E.in_` E.vals uids)

src/Handler/Utils/Company.hs

@@ -222,7 +222,8 @@ defaultSupervisorReasonFilter :: [Filter UserSupervisor]
 defaultSupervisorReasonFilter =
         [UserSupervisorReason  ==. Nothing]
     ||. [UserSupervisorReason  ==. Just (tshow SupervisorReasonCompanyDefault)]
---  ||. [UserSupervisorReason <-. [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]]
+    ||. [UserSupervisorReason  ==. Just (tshow SupervisorReasonAvsSuperior   )]
+--  ||. [UserSupervisorReason <-. Nothing : [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] -- Does <-. work with Nothing?
 
 -- | remove supervisors for given users; maybe restricted to those linked to given companies or supervisors
 deleteDefaultSupervisorsForUsers :: [CompanyId] -> [UserId] -> NonEmpty UserId -> DB Int64
@@ -232,14 +233,6 @@ deleteDefaultSupervisorsForUsers cids sprs usrs =
       $ bcons (notNull sprs) (UserSupervisorSupervisor  <-.  sprs)
       $ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
 
--- | deletes user company association and all company related supervision
--- WARNING: does not check for admin problems!
-deleteCompanyUser :: CompanyId -> [UserId] -> DB (Int64, Int64, Int64)
-deleteCompanyUser cid uids = (,,)
-    <$> deleteWhereCount  [UserCompanyCompany    ==.      cid,  UserCompanyUser          <-. uids]
-    <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids) : defaultSupervisorReasonFilter)
-    <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser       <-. uids) : defaultSupervisorReasonFilter)
-
 -- | retrieve maximum company user priority fo a user
 getCompanyUserMaxPrio :: UserId -> DB Int
 getCompanyUserMaxPrio uid = do

src/Jobs/Handler/LMS.hs

@@ -67,7 +67,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
       now <- liftIO getCurrentTime
       let nowaday = utctDay now
       -- send second reminders first, before enqueing even more, but only for users with currently open LMS and still valid Qualificiations
-      ifNothingM (qualificationRefreshReminder quali) () $ \remindPeriod -> do
+      whenIsJust (qualificationRefreshReminder quali) $ \remindPeriod -> do
         let remindDate = addGregorianDurationClip remindPeriod nowaday
         reminders <- E.select $ do
           (luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser
@@ -91,33 +91,40 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
                   , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
                   }
           _ -> return ()
-
-      ifNothingM (qualificationRefreshWithin quali) () $ \renewalPeriod -> do  -- no refreshWithin, no first reminders
-          let renewalDate = addGregorianDurationClip renewalPeriod nowaday
-          renewalUsers <- E.select $ do
-            quser <- E.from $ E.table @QualificationUser
-            E.where_ $  quser E.^. QualificationUserQualification E.==. E.val qid
-                  E.&&. quser E.^. QualificationUserScheduleRenewal
-                  E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
-                  E.&&. (quser `qualificationValid` now)
-                  E.&&. E.notExists (do
-                          luser <- E.from $ E.table @LmsUser
-                          E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
-                                E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
-                                E.&&. E.isNothing (luser E.^. LmsUserEnded)
-                        )
-            pure quser
-          let usr_job :: Entity QualificationUser -> Job
-              usr_job quser =
-                let uid = quser ^. _entityVal . _qualificationUserUser
-                    uex = quser ^. _entityVal . _qualificationUserValidUntil
-                in if qualificationElearningStart quali
-                    then JobLmsEnqueueUser { jQualification = qid, jUser = uid  }
-                    else JobUserNotification { jRecipient = uid, jNotification =
-                              NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
-                         }
-          forM_ renewalUsers (queueDBJob . usr_job)
-          logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
+      -- send initial reminders
+      whenIsJust (qualificationRefreshWithin quali) $ \renewalPeriod -> do  -- no refreshWithin, no first reminders
+        let renewalDate = addGregorianDurationClip renewalPeriod nowaday
+        renewalUsers <- E.select $ do
+          quser <- E.from $ E.table @QualificationUser
+          E.where_ $  quser E.^. QualificationUserQualification E.==. E.val qid
+                E.&&. quser E.^. QualificationUserScheduleRenewal
+                E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
+                E.&&. (quser `qualificationValid` now)
+                E.&&. E.notExists (do
+                        luser <- E.from $ E.table @LmsUser
+                        E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
+                              E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
+                              E.&&. E.isNothing (luser E.^. LmsUserEnded)
+                      )
+          pure quser
+        let usr_job :: Entity QualificationUser -> Maybe Job
+            usr_job quser =
+              let uid = quser ^. _entityVal . _qualificationUserUser
+                  uex = quser ^. _entityVal . _qualificationUserValidUntil
+                  unf = quser ^. _entityVal . _qualificationUserLastNotified
+                  nfy_cutoff = addGregorianDurationClip renewalPeriod $ utctDay unf
+                  do_notify  = uex > nfy_cutoff || (uex == nfy_cutoff && utctDayTime now >= utctDayTime unf)
+              in if
+                  | qualificationElearningStart quali     -- repetition avoided since LmsUser does not exist
+                    -> Just $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
+                  | do_notify                             -- repetition avoided by QualificationUserLastNotified
+                    -> Just $ JobUserNotification
+                        { jRecipient    = uid
+                        , jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
+                        }
+                  | otherwise -> Nothing
+        forM_ renewalUsers (flip whenIsJust queueDBJob . usr_job)
+        logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
 
 dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
 dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -22,24 +22,22 @@ import Text.Hamlet
 
 
 dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler ()
-dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do
-  (recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,)
+dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = do
+  now <- liftIO getCurrentTime
+  encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
+  (recipient@User{..}, Qualification{..}) <- runDB $ (,)
     <$> getJust jRecipient
     <*> getJust nQualification
-
-  encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
   let entRecipient = Entity jRecipient recipient
       qname = CI.original qualificationName
-  expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
-
-  $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expiry of qualification " <> qname
-
-  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
-  setSubjectI $ MsgMailSubjectQualificationExpiry qname
-
-  editNotifications <- mkEditNotifications jRecipient
-
-  addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
+  userMailT jRecipient $ do
+    expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
+    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+    setSubjectI $ MsgMailSubjectQualificationExpiry qname
+    editNotifications <- mkEditNotifications jRecipient
+    addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
+  runDB $ updateBy (UniqueQualificationUser nQualification jRecipient) [QualificationUserLastNotified =. now]
+  $logDebugS "LMS" $ "Notified " <> tshow encRecipient <> " about soonish expiry of qualification " <> qname
 
 
 dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler ()
@@ -81,7 +79,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
               $logInfoS  "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
             else
               $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname
-        else  $logInfoS  "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname
+        else  $logInfoS  "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname -- should no longer happen to using quserToNotify filter in Jobs.Handler.Lms, but sometimes does after restarts
     _ ->  $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification
 
 

src/Jobs/Handler/SynchroniseAvs.hs

@@ -14,7 +14,7 @@ import Import
 
 import qualified Data.Text            as Text
 import qualified Data.Set             as Set
-import qualified Data.Map             as Map
+-- import qualified Data.Map             as Map
 import qualified Data.Conduit.List as C
 
 import           Database.Esqueleto.Experimental ((:&)(..))
@@ -122,11 +122,11 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
       -- E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
       -- return jobs
     let (unlinked, linked) = foldl' discernJob mempty jobs
-    $logInfoS "SynchronisAvs" [st|AVS synch performing for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
+    $logInfoS "SynchronisAvs" [st|AVS synch start for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
     void $ updateAvsUserByIds  linked
     void $ linktoAvsUserByUIDs unlinked
     runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)]
-    $logInfoS "SynchronisAvs" [st|AVS synch performed for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
+    $logInfoS "SynchronisAvs" [st|AVS synch end for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
     -- we do not reschedule failed synchs here in order to avoid a loop
   where
     discernJob accs (         _ , E.Value (Just api), E.Value True  ) = accs & over _2 (Set.insert api)
@@ -146,12 +146,11 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel
     , avsLicenceSynchMaxChanges   = maxChanges
     } <- getsYesod $ view _appAvsLicenceSynchConf
 
-  let -- TODO: enable a cron job by setting
-      procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Handler ()
+  let procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Handler ()
       procLic aLic up apids
         | n <- Set.size apids, n > 0 =
           let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
-              logit errm = runDB $ logInterface' "AVS" subtype False (isJust errm) (Just n) (fromMaybe "Automatic synch" errm)
+              logit errm = runDB $ logInterface' "AVS" subtype False (isNothing errm) (Just n) (fromMaybe "Automatic synch" errm)
               catchAllAvs = flip catch (\err -> logit (Just $ tshow (err :: SomeException)) >> return (-1))
           in if NTop (Just n) <= NTop maxChanges
               then do
@@ -163,7 +162,7 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel
 
   (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
   -- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
-  multiFirmBlocks <- ifNothingM reasonFilter mempty $ \reasons -> do
+  reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
     now <- liftIO getCurrentTime
     firmBlocks <- runDBRead $ E.select $ do
       (uavs :& _qualUser :& qblock) <- E.from $ E.table @UserAvs
@@ -172,16 +171,14 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel
             qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
             E.&&. qblock `isLatestBlockBefore'` E.val now)
       E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
-          E.&&.  uavs E.^. UserAvsPersonId `E.in_` E.vals (avsLicenceDiffRevokeAll `Set.union` avsLicenceDiffRevokeRollfeld)
-          E.&&. E.not_ (qblock E.^. QualificationUserBlockUnblock)
+          E.&&.  uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
       return $ uavs E.^. UserAvsPersonId
-    firmBlockData <- lookupAvsUsers $ Set.fromList $ map E.unValue firmBlocks                      -- may throw, but we need to abort then
-    return $ Map.keysSet $ Map.filter hasMultipleFirms firmBlockData
+    return $ Set.fromList $ map E.unValue firmBlocks
 
   let fltrIds
         | synchLevel >= 5 = id
-        | synchLevel >= 3 = flip Set.difference   multiFirmBlocks
-        | otherwise       = flip Set.difference $ multiFirmBlocks `Set.union` rsChanged
+        | synchLevel >= 3 = flip Set.difference   reasonFltrdIds
+        | otherwise       = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged
 
   when (synchLevel >= 1) $ procLic AvsNoLicence       False $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
   when (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld

src/Model/Types/Avs.hs

@@ -501,9 +501,11 @@ deriveJSON defaultOptions
   } ''AvsDataPerson
 -}
 
+{- Did not work as intended! Verify, if needed again.
 hasMultipleFirms :: AvsDataPerson -> Bool
 hasMultipleFirms AvsDataPerson{avsPersonPersonCards=crds} =
   1 < Set.size (Set.filter isJust $ Set.map avsDataFirm crds)
+-}
 
 data AvsPersonLicence = AvsPersonLicence
       { avsLicenceRampLicence  :: AvsLicence

src/Model/Types/Misc.hs

@@ -69,7 +69,7 @@ data SupervisorReason
 --       so do not change values here without a proper migration
 instance Show SupervisorReason where
   show SupervisorReasonCompanyDefault = "Firmenstandard"
-  show SupervisorReasonAvsSuperior    = "Vorgesetzer"
+  show SupervisorReasonAvsSuperior    = "Vorgesetzter"
   show SupervisorReasonUnknown        = "Unbekannt"
 
 

src/Utils.hs

@@ -813,6 +813,19 @@ checkAsc :: Ord a => [a] -> Bool
 checkAsc (x:r@(y:_)) = x<=y && checkAsc r
 checkAsc _ = True
 
+-- return a part of a list between two given elements, if it exists
+listBracket :: Eq a => (a,a) -> [a] -> Maybe [a]
+listBracket _     []    = Nothing
+listBracket b@(s,e) (h:t)
+    | s == h    = listUntil  [] t
+    | otherwise = listBracket b t
+  where
+    listUntil _      [] = Nothing
+    listUntil l1 (h1:t1)
+      | e == h1   = Just $ reverse l1
+      | otherwise = listUntil (h1:l1) t1
+
+
 ----------
 -- Sets --
 ----------

templates/avs.hamlet

@@ -35,6 +35,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   $maybe answer <- mbQryLic
     <p>
       ^{answer}  
+  $maybe autodiffs <- mbAutoDiffs
+    <p>
+      #{autodiffs}
 
 <section>
   <p> 

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

@@ -50,27 +50,27 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 $if notNull avsLicenceSynchTimes
   <section>
     <h2>
-      Automatische AVS Fahrlizen Sychronisation
+      Automatische AVS Fahrlizenzen Sychronisation
     <p>
       <dl .deflist>
         <dt .deflist__dt>
           Uhrzeiten Synchronisation
         <dd .deflist__dd>
-          Werktags, weniger Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes}
+          Werktags, wenige Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes}
         <dt .deflist__dt>
           Synchronisationslevel
         <dd .deflist__dd>
-          #{avsLicenceSynchLevel} #
-            $case avsLicenceSynchLevel
-              $of 1
-                Nur Vorfeld-Fahrberechtigungen entziehen
-              $of 2 
-                Vorfeld-Fahrberechtigungen entziehen und gewähren
-              $of 3
-                Vorfeld-Fahrberechtigungen entziehen und gewähren, #
-                so wie Rollfeld-Fahrberechtigungen zu Vorfeld-Fahrberechtigungen herabstufen
-              $of _
-                Vorfeld- und Rollfeld-Fahrberechtigungen entziehen und gewähren
+          <strong>#{avsLicenceSynchLevel}: #
+          $case avsLicenceSynchLevel
+            $of 1
+              Nur Vorfeld-Fahrberechtigungen entziehen
+            $of 2 
+              Vorfeld-Fahrberechtigungen entziehen und gewähren
+            $of 3
+              Vorfeld-Fahrberechtigungen entziehen und gewähren, #
+              so wie Rollfeld-Fahrberechtigungen zu Vorfeld-Fahrberechtigungen herabstufen
+            $of _
+              Vorfeld- und Rollfeld-Fahrberechtigungen entziehen und gewähren
         $maybe reasons <- avsLicenceSynchReasonFilter
           <dt .deflist__dt>
             Ausnahmen
@@ -80,4 +80,4 @@ $if notNull avsLicenceSynchTimes
           <dt .deflist__dt>
             Maximal Änderungen
           <dd .deflist__dd>
-            Keine Synchronisation durchführen, wenn es mehr als #{maxChange} Änderungen pro Level wären
+            Keine Synchronisation eines Levels durchführen, welches mehr als #{maxChange} Änderungen hätte

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

@@ -60,16 +60,16 @@ $if notNull avsLicenceSynchTimes
         <dt .deflist__dt>
           Synchronisation level
         <dd .deflist__dd>
-          #{avsLicenceSynchLevel} #
-            $case avsLicenceSynchLevel
-              $of 1
-                Revoke apron driving licences only
-              $of 2 
-                Grant and revoke apron driving licences only
-              $of 3
-                Grant and revoke apron driving licences and downgrade maneuvering area licences to apron driving licences
-              $of _
-                Grant and revoke all driving licences automatically
+          <strong>#{avsLicenceSynchLevel}: #
+          $case avsLicenceSynchLevel
+            $of 1
+              Revoke apron driving licences only
+            $of 2 
+              Grant and revoke apron driving licences only
+            $of 3
+              Grant and revoke apron driving licences and downgrade maneuvering area licences to apron driving licences
+            $of _
+              Grant and revoke all driving licences automatically
         $maybe reasons <- avsLicenceSynchReasonFilter
           <dt .deflist__dt>
             Exemptions
@@ -79,4 +79,4 @@ $if notNull avsLicenceSynchTimes
           <dt .deflist__dt>
             Max changes
           <dd .deflist__dd>
-            Do not synchronize a licence if the number of changes exceeds #{maxChange}
+            Do not synchronize a licence level if the number of changes exceeds #{maxChange}

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

@@ -5,10 +5,15 @@ $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
-  Bitte beachten, dass Ansprechpartner-Beziehung unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen bestehen.
-  Daraus folgt zum Beispiel, dass wenn <em>x</em> ein Standard-Ansprechpartner für Firma <em>a</em> ist 
-  und wenn <em>y</em> sowohl Firma <em>a</em> als auch <em>b</em> angehört, 
-  dass dann <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird.
+  <p>
+    Bitte beachten: Ansprechpartner-Beziehung bestehen unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen! #
+  
+  <p>
+    Daraus folgt zum Beispiel, dass wenn <em>x</em> ein Standard-Ansprechpartner für Firma <em>a</em> ist #
+    und wenn <em>y</em> sowohl Firma <em>a</em> als auch <em>b</em> angehört, #
+    dass <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird. #
+    Dies kann hier mit der Aktion "Firmenansprechpartner entfernen" nicht geändert werden, #
+    da die Ansprechpartnerbeziehung ja über eine andere Firma weiter existiert.
 
 ^{firmContactInfo}  
 

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

@@ -5,9 +5,12 @@ $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
-  Note that supervision is company independent. 
-  For example, if <em>x</em> is a regular supervisor for company <em>a</em> and <em>y</em> belongs to companies <em>a</em> and <em>b</em>, 
-  then <em>x</em> will be listed as a foreign supervisor for company <em>b</em>.
+  <p>
+    Note that supervisionship is company independent! #
+  <p>
+    For example, if <em>x</em> is a regular supervisor for company <em>a</em> and <em>y</em> belongs to companies <em>a</em> and <em>b</em>, #
+    then <em>x</em> will be listed as a foreign supervisor for company <em>b</em>. #
+    This cannot be changed through action "Remove default supervisor" here, since the external supervisionship persists.
 
 ^{firmContactInfo}
 

test/Database/Fill.hs

@@ -113,10 +113,10 @@ fillDb = do
     , userMobile = Nothing
     , userCompanyPersonalNumber = Just "00000"
     , userCompanyDepartment = Nothing
-    , userPinPassword = Nothing
+    , userPinPassword = Just "1234.5"
     , userPostAddress = Just $ markdownToStoredMarkup ("Büro 127   \nMathematisches Institut der Ludwig-Maximilians-Universität München   \nTheresienstr. 39   \nD-80333 München"::Text)
     , userPostLastUpdate = Nothing
-    , userPrefersPostal = True
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -202,7 +202,7 @@ fillDb = do
     , userPinPassword = Nothing
     , userPostAddress = Nothing
     , userPostLastUpdate = Nothing
-    , userPrefersPostal = True
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -766,7 +766,7 @@ fillDb = do
   void . insert' $ QualificationUser jost       qid_r  (n_day   99) (n_day $  -11) (n_day $  -222) True (n_day' $ -9) -- TODO: better dates!
   void . insert' $ QualificationUser jost       qid_l  (n_day  999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
   void . insert' $ QualificationUser jost       qid_rp (n_day  999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates!
-  qfkleen <- insert' $ QualificationUser gkleen qid_f  (n_day 33) (n_day $ -4) (n_day $ -20) True  (n_day' $ -9)
+  qfkleen <- insert' $ QualificationUser gkleen qid_f  (n_day 10) (n_day $ -40) (n_day $ -120) True  (n_day' $ -20)
   void . insert  $ QualificationUserBlock qfkleen False (n_day' 1) "Future block"   (Just svaupel)
   void . insert' $ QualificationUser maxMuster  qid_f (n_day    0) (n_day $ -2) (n_day $  -8) False (n_day' $ -1)
   qfvaupel <- insert' $ QualificationUser svaupel    qid_f (n_day    2) (n_day $ -1) (n_day $  -2) True  (n_day' $ -9)