diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 1b5295489..f2293ab1f 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -129,6 +129,7 @@ AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Probleme"} als erledigt markier AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Probleme"} erneut eröffnet AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma +AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma AdminProblemUser: Betroffener ProblemTableMarkSolved: Als erledigt markieren ProblemTableMarkUnsolved: Erledigt Markierung löschen diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 12c2b5df7..9e66bf8ea 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -129,6 +129,7 @@ AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened AdminProblemNewCompany: New company from AVS; verify and add default supervisors AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company +AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company AdminProblemUser: Affected ProblemTableMarkSolved: Mark done ProblemTableMarkUnsolved: Reopen as undone diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index a81efaa51..1b7bf5cb8 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -260,16 +260,21 @@ derivePersistFieldJSON ''Transaction -- Datatype for raising admin awareness to certain problems -- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries - +-- Note that is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell data AdminProblem = AdminProblemNewCompany -- new company was noticed, presumably without supervisors { adminProblemCompany :: CompanyId } | AdminProblemSupervisorNewCompany - { adminProblemUser :: UserId -- a default supervisor has changed company - , adminProblemCompany :: CompanyId -- old company where the user had default supervisor rights - , adminProblemCompanyNew :: CompanyId -- new company of the user - , adminProblemSupervisorReroute :: Bool -- reroute included? + { adminProblemUser :: UserId -- a default supervisor has changed company + , adminProblemCompany :: CompanyId -- old company where the user had default supervisor rights + , adminProblemCompanyNew :: CompanyId -- new company of the user + , adminProblemSupervisorReroute :: Bool -- reroute included? + } + | AdminProblemNewlyUnsupervised + { adminProblemUser :: UserId -- user who had supervsior but no longer has + , adminProblemCompanyOld :: Maybe CompanyId -- old company + , adminProblemCompanyNew :: CompanyId -- new company of the user } | AdminProblemUnknown -- miscellanous problem, just displaying text { adminProblemText :: Text diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 54af42978..af85b8a8e 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -323,7 +323,8 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} [ dbSelect (applying _2) id $ return . view (resultProblem . _entityKey) , sortable (Just "time") (i18nCell MsgAdminProblemCreated) $ \( view $ resultProblem . _entityVal . _problemLogTime -> t) -> dateTimeCell t , sortable (Just "info") (i18nCell MsgAdminProblemInfo) $ \( view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> adminProblemCell p - , sortable (Just "firm") (i18nCell MsgTableCompany) $ \(preview $ resultProblem . _entityVal . _problemLogAdminProblem . _adminProblemCompany -> c) -> cellMaybe companyIdCell c + -- , sortable (Just "firm") (i18nCell MsgTableCompany) $ \(preview $ resultProblem . _entityVal . _problemLogAdminProblem . _adminProblemCompany -> c) -> cellMaybe companyIdCell c + , sortable (Just "firm") (i18nCell MsgTableCompany) $ \( view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> cellMaybe companyIdCell $ join (p ^? _adminProblemCompanyOld) <|> (p ^? _adminProblemCompany) , sortable (Just "user") (i18nCell MsgAdminProblemUser) $ \(preview resultUser -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "solved") (i18nCell MsgAdminProblemSolved) $ \( view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t , sortable (Just "solver") (i18nCell MsgAdminProblemSolver) $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR @@ -375,9 +376,12 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} return (act, usrSet) adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a +-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns adminProblemCell AdminProblemNewCompany{} = i18nCell MsgAdminProblemNewCompany adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew +adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew} + = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew adminProblemCell AdminProblemUnknown{adminProblemText} = textCell $ "Problem: " <> adminProblemText diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index b092d3eeb..f1436cebe 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -498,7 +498,7 @@ updateAvsUserByIds apids = do eml_up = em_p_up <|> em_f_up -- ensure that only one email update is produced; there is no Eq instance for the Update type frm_up = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users, CheckAvsUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead - usr_up0 = eml_up `mcons` (frm_up `mcons` per_ups) + usr_up1 = eml_up `mcons` (frm_up `mcons` per_ups) avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` [ UserAvsLastSynch =. now , UserAvsLastSynchError =. Nothing @@ -511,52 +511,57 @@ updateAvsUserByIds apids = do -- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen -- TODO #36 "company postal preference" -- - lift $ do -- no more maybeT neeed from here + lift $ do -- maybeT no longer needed from here onwards -- update company association & supervision Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo + primaryCompanyId <- getUserPrimaryCompany usrId (Just . CompanyKey . companyShorthand) let oldCompanyId = entityKey <$> oldCompanyEnt oldCompanyMb = entityVal <$> oldCompanyEnt - pst_up = mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference + pst_up = if + | isJust oldCompanyId && (oldCompanyId == primaryCompanyId) + -> mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference + | isNothing oldCompanyMb + -> mkUpdateDirect usr newCompany $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) + | otherwise + -> Nothing superReasonComDef = tshow SupervisorReasonCompanyDefault newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done - primaryCompanyId <- getUserPrimaryCompany usrId (Just . CompanyKey . companyShorthand) + - usr_ups <- case oldAvsFirmInfo of + usr_up2 <- case oldAvsFirmInfo of _ | Just newCompanyId == oldCompanyId -- company unchanged entirely - -> return usr_up0 -- => do nothing + -> return Nothing -- => do nothing (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged OR || ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged -> do -- => just update user company association, keeping supervision privileges case oldCompanyId of Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists Just ocid -> do - void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) - void $ updateWhere [ UserSupervisorSupervisor ==. usrId - , UserSupervisorCompany ==. Just ocid - , UserSupervisorReason ==. Just superReasonComDef] -- to we want this last condition? + void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings + void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions + , UserSupervisorCompany ==. Just ocid -- to new company, regardless of + , UserSupervisorReason ==. Just superReasonComDef] -- user [ UserSupervisorCompany =. Just newCompanyId] - return usr_up0 - _ | Just newCompanyId == primaryCompanyId -- Wechsel der AVS-Firma zur FRADrive-Primärfirma + return Nothing + _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company -> do - whenIsJust oldCompanyId $ deleteBy . UniqueUserCompany usrId - when (isJust oldCompanyId) $ deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) - return usr_up0 + whenIsJust oldCompanyId $ \oldCid -> do + deleteBy $ UniqueUserCompany usrId oldCid + deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) + return Nothing _ -- company changed completely - -> do -- switch company, keeping priority + -> do + -- switch user company, keeping old priority (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case - Nothing -> do + Nothing -> void $ insertUnique newUserComp Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute delete ucidOld - void $ insertUnique $ UserCompany usrId newCompanyId False False userCompanyPriority True - - -- forMM_ (get newCompanyId) $ \Company{} -> - -- void $ upsertBy (UniqueUserCompany usrId newCompanyId) (UserCompany usrId newCompanyId False False 0 True) [error "continue here"] -- TODO: better defaults - - let superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.) - _oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [superCompanyFilter oldCompanyId, UserSupervisorReason ~=. superReasonComDef] + void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds + -- adjust supervison + oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] E.insertSelectWithConflict UniqueUserSupervisor ( do @@ -575,10 +580,9 @@ updateAvsUserByIds apids = do , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ] ] ) - _newAPs <- count $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~=. newCompanyId, UserSupervisorReason ~=. superReasonComDef] - -- when (oldAPs > 0 && newAPs <= 0) $ -- TODO: notify admins - -- TODO continue here - return $ pst_up `mcons` usr_up0 + newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) + when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId + return pst_up -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors whenIsJust (newAvsFirmInfo ^. _avsFirmEMailSuperior) $ \supemail -> forMM_ (altM (guessUserByEmail $ supemail ^. from _CI) @@ -588,7 +592,7 @@ updateAvsUserByIds apids = do deleteWhere [UserSupervisorUser ==.usrId, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior] void $ insertUnique $ UserSupervisor supid usrId False (Just newCompanyId) reasonSuperior -- update stored avsinfo - update usrId usr_ups + update usrId $ usr_up2 `mcons` usr_up1 update uaId avs_ups return $ Set.singleton (apid, usrId) diff --git a/src/Utils/Persist.hs b/src/Utils/Persist.hs index 199a3659a..29e67a404 100644 --- a/src/Utils/Persist.hs +++ b/src/Utils/Persist.hs @@ -5,7 +5,7 @@ module Utils.Persist ( fromPersistValueError , fromPersistValueErrorSql - , (~=.) + , (~=.), (~~.) ) where import ClassyPrelude @@ -41,6 +41,12 @@ fromPersistValueErrorSql _ = fromPersistValueError (tshow $ typeRep @a) (tshow $ infix 4 ~=. --- | is Equal or Nothing, do not confuse with Database.Esqueleto.Utils(~=.) which does the same for proper Esqueleto queries +-- | is equal or Nothing, do not confuse with Database.Esqueleto.Utils(~=.) which does the same for proper Esqueleto queries (~=.) :: PersistField a => EntityField v (Maybe a) -> a -> [Filter v] -(~=.) f v = [f ==. Just v] ||. [f ==. Nothing] \ No newline at end of file +(~=.) f v = [f ==. Nothing] ||. [f ==. Just v] + +infix 4 ~~. +-- | maybe is equal or Nothing, +(~~.) :: PersistField a => EntityField v (Maybe a) -> Maybe a -> [Filter v] +(~~.) f Nothing = [f ==. Nothing] +(~~.) f (Just v) = [f ==. Nothing] ||. [f ==. Just v] \ No newline at end of file diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 40669cc2f..88982048b 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -167,6 +167,7 @@ embedRenderMessage f inner mangle = do ] ] +-- ^ Like @embedRenderMessage, but for newtype definitions embedRenderMessageVariant :: Name -- ^ Foundation Type -> Name -- ^ Name of newtype -> (Text -> Text) -- ^ Mangle constructor names