fix(avs): company superiors are now irregular supervisors and old ones are deleted

DETAILS:

Superiors:
- Superiors do not become Company-Default-Supervisors automatically
- Superiors become irregular supervisors without rerouting, existing supervisions are not changed
- Superiors become company users at equal-to-max priority, if not already

For each AVN User update:
- if superior change for unchanged company:
    all company supervisions with remark "Vorgesetzter" are removed
    create admin problem that notifies about superior change (special if new superior could not be created)
- all company associates are irregularly supervised by the new superior with remark "Vorgesetzer"

Questions:
 - company had superior, but no longer: just remove superior-supervisions, do not report admin problem?
 - Problem: superior changed, but we first encounter this through a user changing company. Change is not detected at this point, old superiors remain until an old company associate is updated too

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

@@ -134,6 +134,7 @@ AdminProblemNewCompany: Neue Firma über AVS automatisch erstellt; prüfen und g
 AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma 
 AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma 
 AdminProblemCompanySuperiorChange: Neuer firmenweiter Vorgesetzter.
+AdminProblemCompanySuperiorNotFound t@Text: Neuer unbekannter firmenweiter Vorgesetzter mit E-Mail #{t}, keine Ansprechpartnerbeziehungen eingerichtet.
 AdminProblemCompanySuperiorPrevious: Ehemaliger Vorgesetzter: 
 AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma 
 AdminProblemUser: Betroffener

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

@@ -134,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

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/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

@@ -562,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))
@@ -630,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 =
@@ -645,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

@@ -239,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