chore(AVS): implement user avs update to primary company as outlined in graph in wiki
This commit is contained in:
parent
d213c8e4a1
commit
4c29150371
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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]
|
||||
(~=.) 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]
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user