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
This commit is contained in:
parent
43319fbcca
commit
7e5c256b4c
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}
|
||||
= i18nCell MsgAdminProblemCompanySuperiorChange
|
||||
adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld=Just uid}
|
||||
= i18nCell MsgAdminProblemCompanySuperiorChange <> spacerCell <> i18nCell MsgAdminProblemCompanySuperiorPrevious <> anchorCellM (AdminUserR <$> encrypt uid) (userIdWidget uid)
|
||||
adminProblemCell AdminProblemCompanySuperiorChange{adminProblemUserOld}
|
||||
= i18nCell MsgAdminProblemCompanySuperiorChange <> previousSuperior adminProblemUserOld
|
||||
adminProblemCell AdminProblemCompanySuperiorNotFound{..}
|
||||
= 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]
|
||||
|
||||
|
||||
@ -562,8 +562,8 @@ createAvsUserById muid api = do
|
||||
return uid
|
||||
|
||||
|
||||
getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
|
||||
getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
|
||||
-- getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
|
||||
-- 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 (mbCid, newAfi) mbOldAfi
|
||||
| Just supemail <- newAfi ^. _avsFirmEMailSuperior -- superior given
|
||||
= runMaybeT $ do
|
||||
cid <- MaybeT $ altM (pure mbCid) (getAvsCompanyId newAfi)
|
||||
supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
|
||||
(catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
|
||||
lift $ do
|
||||
oldChanges <- runMaybeT $ do -- remove old superior, if any
|
||||
oldAfi <- MaybeT $ pure mbOldAfi
|
||||
oldEml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
|
||||
oldCid <- MaybeT $ getAvsCompanyId oldAfi
|
||||
oldSup <- MaybeT $ guessUserByEmail $ stripCI oldEml
|
||||
let supChange = oldSup /= supid
|
||||
when (supChange && oldCid == cid) $ lift $ do
|
||||
-- deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company NOTE: we leave this to the oldSuperior's AVS update
|
||||
-- switch supervison
|
||||
-- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness
|
||||
E.update $ \usuper -> do
|
||||
E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ]
|
||||
E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup
|
||||
E.&&. usuper E.^. UserSupervisorCompany E.==. E.justVal cid
|
||||
E.&&. usuper E.^. UserSupervisorReason E.==. E.val reasonSuperior
|
||||
E.&&. E.notExists (do
|
||||
newSuper <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid
|
||||
E.&&. newSuper E.^. UserSupervisorUser E.==. newSuper E.^. UserSupervisorUser
|
||||
)
|
||||
deleteOldSuperior oldSup cid -- remove un-updateable remainders, if any
|
||||
return (supChange, oldSup)
|
||||
let supChange = fst <$> oldChanges
|
||||
oldSup = snd <$> oldChanges
|
||||
unless (supChange == Just False) $ do
|
||||
-- upsert new superior company supervisor
|
||||
mbMaxPrio <- E.selectOne $ do
|
||||
usrCmp <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid
|
||||
return . E.max_ $ usrCmp E.^. UserCompanyPriority
|
||||
let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
|
||||
suprEnt <- upsertBy (UniqueUserCompany supid cid)
|
||||
(UserCompany supid cid True False maxPrio True reasonSuperior)
|
||||
[UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior]
|
||||
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.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
|
||||
]
|
||||
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
|
||||
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
||||
getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
|
||||
newAvsNo = newAfi ^. _avsFirmFirmNo
|
||||
oldAvsNo = oldAfi ^? _Just . _avsFirmFirmNo
|
||||
mbSupEmail = newAfi ^. _avsFirmEMailSuperior
|
||||
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
|
||||
|
||||
|
||||
queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64
|
||||
|
||||
@ -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
|
||||
|
||||
Reference in New Issue
Block a user