Merge branch 'fradrive/jost' into 'master'

HOTFIX(avs): switch company did not always increase priority

Closes #175 and #174

See merge request fradrive/fradrive!41

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

@@ -114,6 +114,7 @@ ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge #{pluralDE n "des
 ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig
 ProblemsUnreachableHeading: Unerreichbare Benutzer
 ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können:
+ProblemsUnreachableButtons: Synchronisation für Unerreichbare starten
 ProblemsRWithoutFHeading: Fahrer mit R ohne F
 ProblemsRWithoutFBody: Diese Fahrer sind wegen einer ungültigen Vorfeld-Fahrberechtigung komplett gesperrt, obwohl eine gültige Rollfeld-Fahrberechtigung besteht:
 ProblemsNoAvsIdHeading: Fahrer ohne AVS-Id
@@ -132,8 +133,9 @@ AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Problem"} erneut eröffnet
 AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
 AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma 
 AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma 
-AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzer.
+AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzter.
-AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzer: 
+AdminProblemCompanySuperiorNotFound t@Text: Neuer unbekannter firmenweiter Vorgesetzter mit E-Mail #{t}, keine Ansprechpartnerbeziehungen eingerichtet.
+AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzter: 
 AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma 
 AdminProblemUser: Betroffener
 ProblemTableMarkSolved: Als erledigt markieren

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

@@ -114,6 +114,7 @@ ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{pl
 ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit
 ProblemsUnreachableHeading: Unreachable Users
 ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications:
+ProblemsUnreachableButtons: Start synchronisation for unreachable users only
 ProblemsRWithoutFHeading: Drivers having 'R' but not 'F'
 ProblemsRWithoutFBody: Drivers without apron driving licence are prohibited from driving, even if they own a valid maneuvering driving licence:
 ProblemsNoAvsIdHeading: Drivers without AVS id
@@ -133,6 +134,7 @@ AdminProblemNewCompany: New company from AVS; verify and add default supervisors
 AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company 
 AdminProblemSupervisorLeftCompany b: Only default company supervisor #{boolText mempty "with reroute" b} for this user changed to new company 
 AdminProblemCompanySuperiorChange: New company wide superior.
+AdminProblemCompanySuperiorNotFound t: Unable to set supervision for new unknown company wide superior having Email #{t}.
 AdminProblemCompanySuperiorPrevious: Previous superior: 
 AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company
 AdminProblemUser: Affected

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

@@ -51,7 +51,9 @@ FilterSupervisor: Hat aktiven Ansprechpartner
 FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört
 FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört
 FilterForeignSupervisor: Hat firmenfremde Ansprechpartner
+FilterIsForeignSupervisee: Ist Ansprechpartner für Firmenfremde
 FilterFirmExtern: Externe Firma
+FilterFirmExternTooltip: Hat die Firma eine Postanschrift im AVS?
 FilterFirmPrimary: Ist primäre Firma in FRADrive
 FilterHasQualification: Hat Firmenangehörige mit aktuell gültiger Qualifikation
 FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig
@@ -59,6 +61,7 @@ FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit
 FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh}
 NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus.
 TableIsDefaultSupervisor: Standardansprechpartner
+TableSuperior: Vorgesetzter
 TableIsDefaultReroute: Standardumleitung
 FormFieldPostal: Benachrichtigungseinstellung
 FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner

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

@@ -51,7 +51,9 @@ FilterSupervisor: Has active supervisor
 FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh}
 FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh}
 FilterForeignSupervisor: Has company-external supervisors
+FilterIsForeignSupervisee: Supervisor for company external users
 FilterFirmExtern: External company
+FilterFirmExternTooltip: i.e. is a postal address registered within AVS?
 FilterFirmPrimary: Is primary company in FRADrive
 FilterHasQualification: Has company associates with currently valid qualification
 FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh}
@@ -59,6 +61,7 @@ FirmSupervisorIndependent: Independent supervisors
 FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users
 NoCompanySelected: Select at least one company, please.
 TableIsDefaultSupervisor: Default supervisor
+TableSuperior: Superior
 TableIsDefaultReroute: Default reroute
 FormFieldPostal: Notification type
 FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor

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

@@ -37,10 +37,10 @@ AuthPWHashAlreadyConfigured: Nutzer:in meldet sich bereits mit FRADrive spezifis
 AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennung an
 UsersCourseSchool: Bereich
 ActionNoUsersSelected: Keine Benutzer:innen ausgewählt
-SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen
+SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen, die Ausführung wird mehrere Minuten benötigen!
-SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden
+SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden, die Ausführung wird eine Weile brauchen!
-SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
+SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, die Ausführung wird mehrere Minuten benötigen!
-SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen
+SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen, die Ausführung kann eine Weile brauchen!
 UserListTitle: Komprehensive Benutzerliste
 AccessRightsSaved: Berechtigungen erfolgreich verändert
 AccessRightsNotChanged: Berechtigungen wurden nicht verändert

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

@@ -37,10 +37,10 @@ AuthPWHashAlreadyConfigured: User already logs in using their FRADrive specific
 AuthPWHashConfigured: User now logs in using their FRADrive specific account
 UsersCourseSchool: Department
 ActionNoUsersSelected: No users selected
-SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}
+SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
-SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today
+SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today, which may take quite a while to complete.
-SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}
+SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}, which may take several minutes to complete.
-SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users
+SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users, which may take quite a while to complete.
 UserListTitle: Comprehensive list of users
 AccessRightsSaved: Successfully updated permissions
 AccessRightsNotChanged: Permissions left unchanged

models/company.model

@@ -8,7 +8,7 @@ Company
   name            CompanyName             -- == (CI Text) -- NOTE: Fraport department name may carry additional information; use the Shorthand with respect to UserCompanyDepartment
   shorthand       CompanyShorthand        -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId   A change to AvsId as primary key is too much work and not strictly necessary due to Uniqueness
   avsId           Int     default=0       -- primary key from avs, use negative numbers for non-AVS companies 
-  prefersPostal   Bool    default=false   -- new company users prefers letters by post instead of email
+  prefersPostal   Bool    default=true    -- new company users prefers letters by post instead of email
   postAddress     StoredMarkup Maybe      -- default company postal address, including company name 
   email           UserEmail Maybe         -- Case-insensitive generic company eMail address  
   -- UniqueCompanyName name               -- Should be Unique in AVS, but we do not yet need to enforce it

routes

@@ -71,7 +71,7 @@
 /admin/avs/#CryptoUUIDUser    AdminAvsUserR    GET POST
 /admin/ldap                   AdminLdapR       GET POST
 /admin/problems               AdminProblemsR			 GET POST 
-/admin/problems/no-contact    ProblemUnreachableR  GET
+/admin/problems/no-contact    ProblemUnreachableR  GET POST
 /admin/problems/no-avs-id     ProblemWithoutAvsId  GET
 /admin/problems/r-without-f   ProblemFbutNoR       GET
 /admin/problems/avs  					ProblemAvsSynchR 		 GET POST

src/Audit/Types.hs

@@ -282,6 +282,11 @@ data AdminProblem
     , adminProblemCompany           :: CompanyId                -- affected company
     , adminProblemUserOld           :: Maybe UserId             -- previous superior
     }
+  | AdminProblemCompanySuperiorNotFound                         -- a company received a new superior user through AVS, but user could not be created from email
+    { adminProblemEmail             :: Maybe Text               -- new superior user's email, not found in LDAP
+    , adminProblemCompany           :: CompanyId                -- affected company
+    , adminProblemUserOld           :: Maybe UserId             -- previous superior
+    }
   | AdminProblemNewlyUnsupervised
     { adminProblemUser              :: UserId                   -- user who had a supervisor but no longer has, due to user company change
     , adminProblemCompanyOld        :: Maybe CompanyId          -- old company

src/Handler/Admin.hs

@@ -24,11 +24,13 @@ import qualified Database.Esqueleto.Experimental as E
 import qualified Database.Esqueleto.Legacy as EL (on) -- needed for dbTable
 import qualified Database.Esqueleto.Utils as E
 
+import Jobs
 import Handler.Utils
 import Handler.Utils.Avs
 import Handler.Utils.Users
 -- import Handler.Utils.Company
 import Handler.Health.Interface
+import Handler.Users (AllUsersAction(..))
 
 import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
@@ -140,12 +142,34 @@ postAdminProblemsR = do
       addMessageI mkind $ msg oks
       when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables
 
-getProblemUnreachableR :: Handler Html
+getProblemUnreachableR,  postProblemUnreachableR :: Handler Html
-getProblemUnreachableR = do
+getProblemUnreachableR = postProblemUnreachableR
+postProblemUnreachableR = do
   unreachables <- runDB retrieveUnreachableUsers
+
+  -- the following form is a nearly identicaly copy from Handler.Users:
+  ((noreachUsersRes, noreachUsersWgt'), noreachUsersEnctype) <- runFormPost . identifyForm FIDUnreachableUsersAction $ buttonForm
+  let noreachUsersWgt = wrapForm noreachUsersWgt' def
+        { formSubmit = FormNoSubmit
+        , formAction = Just $ SomeRoute ProblemUnreachableR
+        , formEncoding = noreachUsersEnctype
+        }
+  formResult noreachUsersRes $ \case
+    AllUsersLdapSync -> do
+      forM_ unreachables $ \Entity{entityKey=uid} -> void . queueJob $ JobSynchroniseLdapUser uid
+      addMessageI Success . MsgSynchroniseLdapUserQueued $ length unreachables
+      redirect ProblemUnreachableR
+    AllUsersAvsSync -> do
+      n <- runDB $ queueAvsUpdateByUID (entityKey <$> unreachables) Nothing
+      addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n
+      redirect ProblemUnreachableR
+
   siteLayoutMsg MsgProblemsUnreachableHeading $ do
     setTitleI   MsgProblemsUnreachableHeading
     [whamlet|
+      <section>
+        <h3>_{MsgProblemsUnreachableButtons}
+        ^{noreachUsersWgt}
       <section>
         #{length unreachables} _{MsgProblemsUnreachableBody}
         <ul>

src/Handler/Firm.hs

@@ -97,7 +97,7 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
                   <$> aopt boolField'                       (fslI MsgFirmActResetSuperKeep)                     (Just $ Just False)
                   <*> aopt checkBoxField                    (fslI MsgFirmActResetMutualSupervision)             (Just $ Just True )
     mkAct _     FirmActAddSupervisors   = singletonMap FirmActAddSupervisors   $ FirmActAddSupervisorsData
-                  <$> areq (textField & cfAnySeparatedSet)  (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
+                  <$> areq (textField & cfAnySeparatedSet)  (fslI MsgFirmSuperDefault & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
                   <*> areq checkBoxField                    (fslI MsgTableIsDefaultReroute)                                                             (Just True)
                   <*> aopt postalEmailField                 (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip)                                Nothing
                   <*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons)
@@ -666,6 +666,8 @@ mkFirmAllTable isAdmin uid = do
                 E.&&. qual E.^. QualificationShorthand E.==. E.val criterion
                 E.&&. validQualification now usrQual
             )
+          , single ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress))
+            )
           ]
         dbtFilterUI mPrev = mconcat
           [ fltrCompanyNameUI mPrev
@@ -675,7 +677,8 @@ mkFirmAllTable isAdmin uid = do
           , prismAForm (singletonFilter "is-supervisor")                              mPrev $ aopt textField (fslI MsgTableSupervisor)
           , prismAForm (singletonFilter "is-default-supervisor")                      mPrev $ aopt textField (fslI MsgFirmSuperDefault)
           , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor)
-          , prismAForm (singletonFilter "company-postal"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern)
+          , prismAForm (singletonFilter "company-postal"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern & setTooltip MsgFilterFirmExternTooltip)
+          , prismAForm (singletonFilter "company-address")                            mPrev $ aopt textField (fslI MsgFirmAddress)
           , fltrQualificationHdrUI MsgFilterHasQualification mPrev
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
@@ -801,24 +804,27 @@ mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set
 mkFirmUserTable isAdmin cid = do
   mr <- getMessageRender
   let
-    mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do
+    reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
+    mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr, E.Value mbmbReason) = do
       uuid <- toPathPiece <$> encryptUser uid
-      return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr)
+      return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr, mbmbReason == Just reasonSuperior)
 
     procOptions rawSupers = do
       procSupers <- traverse mkSprOption rawSupers
       return $ mkOptionListGrouped $ filter (notNull . snd)
-             [ (mr MsgFirmSuperDefault  , [opt | (opt, Just True ) <- procSupers])
+             [ (mr MsgTableSuperior     , [opt | (opt, _         , True ) <- procSupers])
-             , (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers])
+             , (mr MsgFirmSuperDefault  , [opt | (opt, Just True , False) <- procSupers])
-             , (mr MsgFirmSuperForeign  , [opt | (opt, Nothing   ) <- procSupers])
+             , (mr MsgFirmSuperIrregular, [opt | (opt, Just False, False) <- procSupers])
+             , (mr MsgFirmSuperForeign  , [opt | (opt, Nothing   , False) <- procSupers])
              ]
 
   rawSupers <- E.select $ do
     (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany
             `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid)
     E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
+        E.||.  (usrCmp E.?. UserCompanyReason E.?=. E.val reasonSuperior)
         E.||.  E.exists (firmQuerySupervisedBy cid Nothing usr)
-    return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor)
+    return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor, usrCmp E.?. UserCompanyReason)
   let
     -- supervisorField :: Field Handler UserId
     -- supervisorField  =      selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
@@ -1198,20 +1204,22 @@ mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Se
 mkFirmSuperTable isAdmin cid = do
   msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo
   let
-    reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
+    reasonSuperior = tshow SupervisorReasonAvsSuperior
     -- fsh = unCompanyKey cid
     resultDBTable = DBTable{..}
       where
         dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do
           EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid
-          E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor)
+          E.where_ $  E.isTrue (usrCmp E.?. UserCompanySupervisor) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr)
-              E.||.  E.exists (firmQuerySupervisedBy cid Nothing usr)
+          -- let uc_reason = E.joinV (usrCmp E.?. UserCompanyReason)
           return ( usr
                  , usr & firmCountForSupervisor cid Nothing
                  , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
                  , usrCmp E.?. UserCompanySupervisor
                  , usrCmp E.?. UserCompanySupervisorReroute
-                 , E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.val reasonSuperior)) usr)
+                 -- , (E.isJust uc_reason E.&&. uc_reason E.==. E.justVal reasonSuperior) -- NOTE: this is problematic, as obvious approaches caused errors such as: Failed to parse Haskell type bool, received PersistNull, since the SQL comparison with NULL returns NULL
+                 , (E.coalesceDefault [E.joinV (usrCmp E.?. UserCompanyReason)] (E.val mempty) E.==. E.val reasonSuperior) -- works as well
+                    E.||. E.exists (firmQuerySupervisedBy cid (Just (\usrSpr -> usrSpr E.^. UserSupervisorReason E.==. E.justVal reasonSuperior)) usr)
                  )
         dbtRowKey = querySuperUser >>> (E.^. UserId)
         dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute, isSuperior) -> do
@@ -1232,15 +1240,11 @@ mkFirmSuperTable isAdmin cid = do
           , colUserEmail
           , sortable (Just "supervised")  (i18nCell MsgTableCompanyNrEmpSupervised)  $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
           , sortable (Just "rerouted")    (i18nCell MsgTableCompanyNrEmpRerouted  )  $ \(view resultSuperCompanyReroutes   -> nr) -> wgtCell $ word2widget nr
-          -- , sortable (Just "def-super")   (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper   -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell }
+          , sortable (Just "def-super")   (i18nCell MsgTableIsDefaultSupervisor) $ view resultSuperCompanyDefaultSuper >>> \case
-          , sortable (Just "def-super")   (i18nCell MsgTableIsDefaultSupervisor) $ \row ->
+              Nothing      -> iconCell IconSupervisorForeign
-              let mb = row ^. resultSuperCompanyDefaultSuper
+              (Just True ) -> iconCell IconSupervisor
-                  sp = row ^. resultSuperCompanySuperior
+              (Just False) -> iconSpacerCell
-              in case (mb,sp) of
+          , sortable Nothing  (i18nCell MsgTableSuperior) $ view resultSuperCompanySuperior >>> flip ifIconCell IconSuperior
-                  (_     , True) -> iconCell IconSuperior
-                  (Nothing   ,_) -> iconCell IconSupervisorForeign
-                  (Just True ,_) -> iconCell IconSupervisor
-                  (Just False,_) -> iconSpacerCell
           , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute)    $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True)
           , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr
           ]
@@ -1263,16 +1267,36 @@ mkFirmSuperTable isAdmin cid = do
           ]
         dbtFilter = mconcat
           [ single $ fltrUserNameEmail querySuperUser
+          , singletonMap "is-foreign-supervisor" $ FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) ->
+              case criterion of
+                  Nothing     -> E.true
+                  Just True   -> E.isNothing $ suc E.?. UserCompanyUser
+                  Just False  -> E.isJust    $ suc E.?. UserCompanyUser
+          , singletonMap "super-relation-foreign" $ FilterColumn $ \row (getLast -> criterion) ->
+              let checkSuper = do
+                    usrSpr <- E.from $ E.table @UserSupervisor
+                    E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId
+                        E.&&.  E.exists (do
+                                  usr <- E.from $  E.table @UserCompany
+                                  E.where_ $ usr E.^. UserCompanyCompany E.!=. E.val cid
+                                    E.&&.    usr E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorUser
+                                )
+              in case criterion of
+                  Nothing     -> E.true
+                  Just True   -> E.exists    checkSuper
+                  Just False  -> E.notExists checkSuper
           ]
         dbtFilterUI mPrev = mconcat
           [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev
+          , prismAForm (singletonFilter "is-foreign-supervisor"   . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperForeign)
+          , prismAForm (singletonFilter "super-relation-foreign"  . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterIsForeignSupervisee)
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
         acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData)
         acts = mconcat
           [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
           , singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData
-              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor)  (Just $ Just True)
+              <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperDefault)  (Just $ Just True)
               <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute)      Nothing
               <*  aformMessage msgSupervisorUnchanged
           , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
@@ -1352,7 +1376,7 @@ postFirmSupersR fsh = do
 
   formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm]
 
-  siteLayout (citext2widget fsh) $ do
+  siteLayout (citext2widget companyName) $ do
     setTitle $ citext2Html $ fsh <> " Supers"
     let firmContactInfo = $(widgetFile "firm-contact-info")
     $(i18nWidgetFile "firm-supervisors")

src/Handler/Health.hs

@@ -6,6 +6,7 @@ module Handler.Health where
 
 import Import
 
+import Data.Time.Format.ISO8601 (iso8601Show)
 import Handler.Utils.DateTime (formatTimeW)
 
 import qualified Data.Aeson.Encode.Pretty as Aeson
@@ -77,12 +78,12 @@ getHealthR = do
                       #{boolSymbol (healthOk hcstatus)} #
                       $case report
                         $of HealthLDAPAdmins (Just found)
-                          #{textPercent found 1}  
+                          #{textPercent found 1}
                         $of HealthActiveJobExecutors (Just active)
                           #{textPercent active 1}
                         $of _
                       <div>
-                        ^{formatTimeW SelFormatDateTime lUp}                      
+                        ^{formatTimeW SelFormatDateTime lUp}
           |]
         provideJson healthReports
         provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports
@@ -115,32 +116,31 @@ getStatusR = do
   starttime <- getsYesod appStartTime
   (currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
   -- ft <- formatTime'  "%Y-%m-%d %H:%M:%S" currtime
-  withUrlRenderer 
+  let diffTime :: UTCTime -> Text
+      diffTime = pack . iso8601Show . calendarTimeTime . fromIntegral . truncate . diffUTCTime currtime
+  withUrlRenderer
     [hamlet|
       $doctype 5
       <html lang=en>
-        <head>        
+        <head>
           <title>Status
         <body>
           $maybe env_ver <- env_version
             <p>
               Environment version #{env_ver}
-          <p> 
-            Current Time <br> 
-            #{show currtime} <br>     
           <p>
-            Instance Start <br> 
+            Current Time <br>
+            #{show currtime} <br>
+          <p>
+            Instance Start <br>
             #{show starttime} #
-            Uptime: #{show $ ddays starttime currtime} days.
+            Uptime: #{diffTime starttime}
           <p>
             Compile Time <br>
             #{show cTime} #
-            Build age: #{show $ ddays cTime currtime} days.
+            Build age: #{diffTime cTime}
     |]
-  where 
+  where
-    -- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction  
+    -- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction
     cTime :: UTCTime
-    cTime = $compileTime
+    cTime = $compileTime
-
-    ddays :: UTCTime -> UTCTime -> Double
-    ddays tstart tstop = (/100) $ fromIntegral $ round $ diffUTCTime tstop tstart / (36 * 24)

src/Handler/Users.hs

@@ -44,7 +44,7 @@ import Data.Aeson hiding (Result(..))
 
 -- import Handler.Users.Add as Handler.Users
 
-import qualified Data.Conduit.List as C
+-- import qualified Data.Conduit.List as C
 
 import qualified Data.HashSet as HashSet
 
@@ -424,7 +424,8 @@ postUsersR = do
 
   formResult allUsersRes $ \case
     AllUsersLdapSync -> do
-      runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
+      -- runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) -- to slow to execute directly
+      queueJob' JobSynchroniseLdapAll
       addMessageI Success MsgSynchroniseLdapAllUsersQueued
       redirect UsersR
     AllUsersAvsSync -> do

src/Handler/Utils.hs

@@ -163,6 +163,9 @@ redirectKeepGetParams route = liftHandler $ do
   getps <- reqGetParams <$> getRequest
   redirect (route, getps)
 
+previousSuperior :: (IsDBTable m a) => Maybe UserId -> DBCell m a
+previousSuperior Nothing    = mempty
+previousSuperior (Just uid) = spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
 
 adminProblemCell :: (IsDBTable m a) => AdminProblem -> DBCell m a
 -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
@@ -173,10 +176,10 @@ adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminP
   = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
 adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
   = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
-adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Nothing}
+adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld}
-  = i18nCell MsgAdminProblemCompanySuperiorChange
+  = i18nCell MsgAdminProblemCompanySuperiorChange <> previousSuperior adminProblemUserOld
-adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
+adminProblemCell AdminProblemCompanySuperiorNotFound{..}
-  = i18nCell MsgAdminProblemCompanySuperiorChange <> spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
+  = i18nCell (MsgAdminProblemCompanySuperiorNotFound (fromMaybe "???" adminProblemEmail)) <> previousSuperior adminProblemUserOld
 adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
   = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
 adminProblemCell AdminProblemUnknown{adminProblemText}
@@ -209,11 +212,18 @@ adminProblem2Text adprob = do
     --         return $ mr MsgAdminProblemCompanySuperiorChange
     --       Just User{userDisplayName = udn, userSurname = usn} ->
     --         return $ mr $ SomeMessages [SomeMessage MsgAdminProblemCompanySuperiorChange, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
+    AdminProblemCompanySuperiorNotFound{adminProblemUserOld=mbuid, adminProblemEmail=eml}
+      ->  let basemsg = MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml
+          in  maybeT (return $ mr basemsg) $ do
+            uid <- MaybeT $ pure mbuid
+            User{userDisplayName = udn, userSurname = usn} <- MaybeT $ get uid
+            pure $ mr $ SomeMessages [SomeMessage basemsg, SomeMessage MsgAdminProblemCompanySuperiorPrevious, SomeMessage udn, SomeMessage usn]
     AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
       -> return $ mr $ SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, company2msg adminProblemCompanyNew]
     AdminProblemUnknown{adminProblemText}
       -> return $ "Problem: " <> adminProblemText
 
+-- | Show AdminProblem as message, used in message pop-up after manually switching companies for a user
 msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
 msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
   SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
@@ -223,8 +233,10 @@ msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, admi
   SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp]
 msgAdminProblem AdminProblemCompanySuperiorChange{adminProblemCompany=comp} = return $
   SomeMessages [SomeMessage   MsgAdminProblemCompanySuperiorChange, text2message ": ", company2msg comp]
+msgAdminProblem AdminProblemCompanySuperiorNotFound{adminProblemCompany=comp, adminProblemEmail=eml} = return $
+  SomeMessages [SomeMessage $ MsgAdminProblemCompanySuperiorNotFound $ fromMaybe "???" eml, text2message ": ", company2msg comp]
 msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
-  SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
+  SomeMessages [SomeMessage   MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
 msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
   someMessages ["Problem: ", err]
 

src/Handler/Utils/Avs.hs

@@ -99,10 +99,10 @@ catchAVS2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) Avs
 catchAVS2log = catchAVShandler False True False Nothing
 
 catchAll2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m a -> m ()
-catchAll2log  = voidMaybe $ catchAVShandler True True False Nothing
+catchAll2log  = voidMaybe catchAll2log'
 
--- catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException, Monoid a) => m a -> m ()
+catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
--- catchAll2log' = voidMaybe $ catchAVShandler True True False mempty
+catchAll2log' = catchAVShandler True True False Nothing
 
 catchAVShandler :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => Bool -> Bool -> Bool -> a -> m a -> m a
 catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHandlers)
@@ -493,13 +493,12 @@ createAvsUserById muid api = do
         -- check for matching existing user
         let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
             -- persMail  :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
-        oldUsr <- runDBRead $ do
+        oldUsr <- runDB $ do
-          mbUid <- if isJust muid
+          mbUid <- firstJustM $ return muid : maybe [] (\ipn ->
-              then return muid
+                [ getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn] -- must ensure filter isnt ==. Nothing
-              else firstJustM $ catMaybes
+                , catchAll2log' (Just . entityKey <$> ldapLookupAndUpsert ipn) -- attempt to insert by LDAP first
-                [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
-                -- , persMail       <&> guessUserByEmail -- this did not work, as unfortunately, superiors are sometimes listed under _avsInfoPersonEMail!
                 ]
+                ) internalPersNo
           mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
           return (mbUid, mbUAvs)
         usrCardNo <- queryAvsFullCardNo api
@@ -563,8 +562,8 @@ createAvsUserById muid api = do
               return uid
 
 
-getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
+-- getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
-getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
+-- getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
 
 -- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo
 getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
@@ -631,7 +630,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
           _otherwise -> return res_cmp
         $logInfoS "AVS" "Update company completed."
         return res_cmp2
-    void $ upsertCompanySuperior (Just $ entityKey cmpEnt, newAvsFirmInfo) mbOldAvsFirmInfo                -- ensure firmInfo superior is supervisor
+    void $ upsertCompanySuperior cmpEnt newAvsFirmInfo mbOldAvsFirmInfo                -- ensure firmInfo superior is supervisor
     return cmpEnt
   where
     firmInfo2key =
@@ -646,92 +645,60 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
       ]
 
 -- upsert company supervisor from AvsFirmEMailSuperior
-upsertCompanySuperior :: (Maybe CompanyId, AvsFirmInfo) -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId))
+upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> DB () -- (Maybe UserId) possibly return superior, but currently not needed
-upsertCompanySuperior (mbCid, newAfi) mbOldAfi
+upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi = do
-    | Just supemail <- newAfi ^. _avsFirmEMailSuperior -- superior given
+  let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
-      = runMaybeT $ do
+      getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
-        cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi)
+      newAvsNo    = newAfi ^.         _avsFirmFirmNo
-        supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
+      oldAvsNo    = oldAfi ^? _Just . _avsFirmFirmNo
-                               (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
+      mbSupEmail  = newAfi ^.         _avsFirmEMailSuperior
-        lift $ do
+      mbOldEmail  = oldAfi ^? _Just . _avsFirmEMailSuperior . _Just
-          oldChanges <- runMaybeT $ do -- remove old superior, if any
+      getSupId    =  getInsertUid                `traverseJoin` mbSupEmail
-            oldAfi <- MaybeT $ pure mbOldAfi
+      getOldId    = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail
-            oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
+      unchangedCompany  = oldAvsNo   == Just newAvsNo
-            oldCid <- MaybeT $ getAvsCompanyId oldAfi
+      changedSuperior   = mbSupEmail /= mbOldEmail     -- beware, both could be Nothing
-            oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml
+  mbSupId <- getSupId
-            let supChange = oldSup /= supid
+  -- delete old superiors, if any
-            when (supChange && oldCid == cid) $ lift $ do
+  when (unchangedCompany && changedSuperior) $
-              -- deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company NOTE: we leave this to the oldSuperior's AVS update
+    deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
-              -- switch supervison
+                        [ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
-              -- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness
+  -- ensure superior supervision
-              E.update $ \usuper -> do
+  case mbSupId of
-                E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ]
+    Just supId -> do
-                E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup
+      -- ensure association between company and superior at equal-to-top priority
-                    E.&&.  usuper E.^. UserSupervisorCompany    E.==. E.justVal cid
+      prio <- getCompanyUserMaxPrio supId
-                    E.&&.  usuper E.^. UserSupervisorReason     E.==. E.val reasonSuperior
+      void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
-                    E.&&. E.notExists (do
+      -- ensure all company associates are irregularly supervised by the superior
-                        newSuper <- E.from $ E.table @UserSupervisor
+      E.insertSelectWithConflict UniqueUserSupervisor
-                        E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid
+        (do
-                            E.&&.  newSuper E.^. UserSupervisorUser       E.==. newSuper E.^. UserSupervisorUser
+          usr <- E.from $ E.table @UserCompany
-                      )
+          E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
-              deleteOldSuperior oldSup cid    -- remove un-updateable remainders, if any
+              -- E.&&. E.notExists (do                                                              -- restrict to primary company only
-            return (supChange, oldSup)
+              --     othr <- E.from $ E.table @UserCompany
-          let supChange = fst <$> oldChanges
+              --     E.where_ $ othr E.^. UserCompanyPriority E.>.  usr E.^. UserCompanyPriority
-              oldSup    = snd <$> oldChanges
+              --         E.&&.  othr E.^. UserCompanyUser     E.==. usr E.^. UserCompanyUser
-          unless (supChange == Just False) $ do
+              --         E.&&.  othr E.^. UserCompanyCompany  E.!=. E.val cid                       -- redundant due to > above, but likely performance improving
-            -- upsert new superior company supervisor
+              --   )
-            mbMaxPrio <- E.selectOne $ do
+          return $ UserSupervisor
-              usrCmp <- E.from $ E.table @UserCompany
+            E.<#  E.val supId
-              E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid
+            E.<&> (usr E.^. UserCompanyUser)
-              return . E.max_ $ usrCmp E.^. UserCompanyPriority
+            E.<&> E.false
-            let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
+            E.<&> E.justVal cid
-            suprEnt <- upsertBy (UniqueUserCompany supid cid)
+            E.<&> E.val reasonSuperior
-                                  (UserCompany supid cid True False maxPrio True reasonSuperior)
+        )
-                                  [UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior]
+        (\_old _new -> [] -- do not change exisitng supervision
-            E.insertSelectWithConflict UniqueUserSupervisor
+          -- [ UserSupervisorCompany               E.=. new E.^. UserSupervisorCompany
-              (do
+          -- , UserSupervisorReason                E.=. new E.^. UserSupervisorReason
-                usr <- E.from $ E.table @UserCompany
+          -- , UserSupervisorRerouteNotifications  E.=. new E.^. UserSupervisorRerouteNotifications
-                E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
+          -- ]
-                    -- E.&&. E.notExists (do                                                              -- restrict to primary company only
+        )
-                    --     othr <- E.from $ E.table @UserCompany
+      when (unchangedCompany && changedSuperior) $ do
-                    --     E.where_ $ othr E.^. UserCompanyPriority E.>.  usr E.^. UserCompanyPriority
+        oldSupId <- getOldId
-                    --         E.&&.  othr E.^. UserCompanyUser     E.==. usr E.^. UserCompanyUser
+        reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
-                    --         E.&&.  othr E.^. UserCompanyCompany  E.!=. E.val cid                       -- redundant due to > above, but likely performance improving
+    Nothing ->
-                    --   )
+      when (unchangedCompany && changedSuperior) $ do
-                return $ UserSupervisor
+        oldSupId <- getOldId
-                  E.<#  E.val supid
+        reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
-                  E.<&> (usr E.^. UserCompanyUser)
-                  E.<&> E.val (suprEnt ^. _entityVal . _userCompanySupervisorReroute)
-                  E.<&> E.justVal cid
-                  E.<&> E.val reasonSuperior
-              )
-              (\_old new ->
-                [ -- UserSupervisorSupervisor E.=. new E.^. UserSupervisorSupervisor  -- this is already given in case of conflict
-                  UserSupervisorCompany               E.=. new E.^. UserSupervisorCompany
-                , UserSupervisorReason                E.=. new E.^. UserSupervisorReason
-                , UserSupervisorRerouteNotifications  E.=. new E.^. UserSupervisorRerouteNotifications
-                ]
-              )
-            reportAdminProblem $ AdminProblemCompanySuperiorChange supid cid oldSup
-          return (cid,supid)
-    | Just oldSupeEmail <- mbOldAfi ^. _Just . _avsFirmEMailSuperior -- no more superior, delete old one
-      = do
-          void $ runMaybeT $ do
-            oldAfi <- MaybeT $ pure mbOldAfi
-            oldCid <- MaybeT $ getAvsCompanyId oldAfi
-            oldSup <- MaybeT $ guessUserByEmail $ stripCI oldSupeEmail
-            lift $ deleteOldSuperior oldSup oldCid
-          return Nothing
-    | otherwise -- neither new nor old superior
-      = return Nothing
-  where
-    reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
-
-    deleteOldSuperior oldSup oldCid =
-      deleteWhere [ UserSupervisorSupervisor ==. oldSup
-                  , UserSupervisorCompany ==. Just oldCid
-                  , UserSupervisorReason ==. reasonSuperior
-                  ]
 
 
 queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64

src/Handler/Utils/Company.hs

@@ -169,6 +169,10 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
         usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email
         usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrDisplayEmailUp]
                 --  [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional
+
+        newUserComp       = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
+        superReasonComDef = tshow SupervisorReasonCompanyDefault
+
     -- update uid usrUpdate
     -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association
     case mbUsrComp of
@@ -180,7 +184,7 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
         | newCompanyId == oldCompanyId -> return mempty -- nothing to do
         | otherwise -> do -- switch company
             when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
-            void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
+            void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = succ oldPrio}
               [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
             -- supervised by uid
             supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
@@ -213,9 +217,6 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
                          $ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
                            newlyUnsupervised
             return (usrUpdate ,problems)
-  where
-    newUserComp       = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
-    superReasonComDef = tshow SupervisorReasonCompanyDefault
 
 defaultSupervisorReasonFilter :: [Filter UserSupervisor]
 defaultSupervisorReasonFilter =
@@ -238,3 +239,12 @@ 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
+  mbMaxPrio <- E.selectOne $ do
+    usrCmp <- E.from $ E.table @UserCompany
+    E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val uid
+    return . E.max_ $ usrCmp E.^. UserCompanyPriority
+  return $ maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio

src/Jobs/Handler/SynchroniseLdap.hs

@@ -3,7 +3,9 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Jobs.Handler.SynchroniseLdap
-  ( dispatchJobSynchroniseLdap, dispatchJobSynchroniseLdapUser
+  ( dispatchJobSynchroniseLdap
+  , dispatchJobSynchroniseLdapUser
+  , dispatchJobSynchroniseLdapAll
   , SynchroniseLdapException(..)
   ) where
 
@@ -49,7 +51,7 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
     Just ldapPool ->
       runDB . void . runMaybeT . handleExc $ do
         user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser
-        let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey 
+        let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey
         $logInfoS "SynchroniseLdap" [st|Synchronising #{upsertIdent}|]
 
         reTestAfter <- getsYesod $ view _appLdapReTestFailover
@@ -62,3 +64,6 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
     handleExc
       = catchMPlus (Proxy @CampusUserException)
       . catchMPlus (Proxy @CampusUserConversionException)
+
+dispatchJobSynchroniseLdapAll :: JobHandler UniWorX
+dispatchJobSynchroniseLdapAll = JobHandlerAtomic . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)

src/Jobs/Types.hs

@@ -97,6 +97,7 @@ data Job
                               , jIteration :: Natural
                               }
   | JobSynchroniseLdapUser    { jUser :: UserId }
+  | JobSynchroniseLdapAll
   | JobSynchroniseAvs         { jNumIterations
                               , jEpoch
                               , jIteration :: Natural
@@ -350,6 +351,7 @@ jobNoQueueSame = \case
   JobDeleteTransactionLogIPs{}        -> Just JobNoQueueSame
   JobSynchroniseLdap{}                -> Just JobNoQueueSame
   JobSynchroniseLdapUser{}            -> Just JobNoQueueSame
+  JobSynchroniseLdapAll{}             -> Just JobNoQueueSameTag
   JobSynchroniseAvs{}                 -> Just JobNoQueueSame
   -- JobSynchroniseAvsUser{}             -> Just JobNoQueueSame
   -- JobSynchroniseAvsId{}               -> Just JobNoQueueSame

src/Utils/Form.hs

@@ -320,6 +320,7 @@ data FormIdentifier
   | FIDAddSupervisor
   | FIDFirmUserChangeRequest
   | FIDFirmAction
+  | FIDUnreachableUsersAction
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where

test/Database/Fill.hs

@@ -655,14 +655,14 @@ fillDb = do
                           , let rcName  = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n)
                           , let rcShort = CI.mk $ "RC" <> tshow n
                           ]
-  void . insert' $ UserCompany jost    fraportAg    True   True  0 False $ Just "Vorgesetzter"
+  void . insert' $ UserCompany jost    fraportAg    True   True  0 False $ Just $ tshow SupervisorReasonAvsSuperior
-  void . insert' $ UserCompany svaupel nice         True   False 2 False $ Just "Vorgesetzter"
+  void . insert' $ UserCompany svaupel nice         True   False 2 False $ Just $ tshow SupervisorReasonAvsSuperior
   void . insert' $ UserCompany svaupel ffacil       False  False 1 False $ Just "Irgendwas"
   void . insert' $ UserCompany svaupel bpol         True   False 2 False $ Just "Irgendwas"
   void . insert' $ UserCompany svaupel fraGround    True   False 1 False $ Just "Irgendwas"
   void . insert' $ UserCompany gkleen  nice         False  False 1 True  $ Just "Winterdienst"
   void . insert' $ UserCompany gkleen  fraGround    False  True  2 False $ Just "Irgendwas"
-  void . insert' $ UserCompany gkleen  bpol         False  True  1 False $ Just "Irgendwas"
+  void . insert' $ UserCompany gkleen  bpol         False  True  1 False $ Just $ tshow SupervisorReasonAvsSuperior
   void . insert' $ UserCompany fhamann bpol         False  False 1 True  $ Just "Irgendwas"
   void . insert' $ UserCompany fhamann ffacil       True   True  2 True  $ Just "Irgendwas"
   void . insert' $ UserCompany fhamann nice         False  False 3 False $ Just "Winterdienst"
@@ -687,14 +687,14 @@ fillDb = do
   -- void . insert' $ UserSupervisor svaupel gkleen    False
   -- void . insert' $ UserSupervisor svaupel fhamann   True
   -- void . insert' $ UserSupervisor sbarth tinaTester True
-  let supvs = [ UserSupervisor jost gkleen            True  (Just fraportAg)  (Just "Staff")
+  let supvs = [ UserSupervisor jost gkleen            True  (Just fraportAg)  (Just $ tshow SupervisorReasonAvsSuperior)
-              , UserSupervisor jost svaupel           False (Just fraportAg)  (Just "Staff")
+              , UserSupervisor jost svaupel           False (Just fraportAg)  (Just $ tshow SupervisorReasonAvsSuperior)
               , UserSupervisor jost sbarth            False (Just fraportAg)  (Just "Staff")
               , UserSupervisor jost tinaTester        True  (Just fraportAg)  (Just "Staff")
               , UserSupervisor jost jost              True  (Just fraportAg)  (Just "Staff")
               , UserSupervisor svaupel gkleen         False (Just nice)       (Just "Staff")
               , UserSupervisor svaupel fhamann        True  (Just nice)       (Just "Staff")
-              , UserSupervisor sbarth tinaTester      True  (Just nice)       (Just "Staff")
+              , UserSupervisor sbarth tinaTester      True  (Just nice)       (Just $ tshow SupervisorReasonAvsSuperior)
               , UserSupervisor gkleen fhamann         False (Just fraGround)  (Just "Staff")
               , UserSupervisor gkleen gkleen          True  (Just fraGround)  (Just "Staff")
               , UserSupervisor tinaTester tinaTester  False Nothing           (Just "Staff")