diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 279d59ebe..a80ceead2 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index ebca9a147..f69fda9e5 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/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 diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 26213d616..f20aaed95 100644 --- a/src/Audit/Types.hs +++ b/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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index b7a112d86..4abcd0ce2 100644 --- a/src/Handler/Utils.hs +++ b/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} - = 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] diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 81942cb9c..292fad0df 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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 diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 5ee079280..b3f428b83 100644 --- a/src/Handler/Utils/Company.hs +++ b/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