fix(avs): fix #224 repeated superior changes no longer occur
furthermore AdminProblems are only inserted if the same problem does not exist unsolved
This commit is contained in:
parent
56c2be7b79
commit
3960931bb5
25
src/Audit.hs
25
src/Audit.hs
@ -1,7 +1,9 @@
|
||||
-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Audit
|
||||
( module Audit.Types
|
||||
, AuditException(..)
|
||||
@ -17,6 +19,8 @@ import Import.NoModel
|
||||
import Settings
|
||||
import Model
|
||||
import Database.Persist.Sql
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Audit.Types
|
||||
|
||||
import qualified Data.Text as Text
|
||||
@ -129,7 +133,7 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User
|
||||
-> Text -- ^ Any additional information
|
||||
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
||||
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
|
||||
logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do
|
||||
logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do
|
||||
interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
|
||||
logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo
|
||||
|
||||
@ -173,20 +177,25 @@ logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogS
|
||||
|
||||
reportAdminProblem :: ( IsSqlBackend (YesodPersistBackend (HandlerSite m))
|
||||
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
|
||||
, MonadHandler m
|
||||
, MonadHandler m
|
||||
-- , HasCallStack
|
||||
)
|
||||
=> AdminProblem -- ^ Problem to record
|
||||
=> AdminProblem -- ^ Problem to record
|
||||
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
||||
-- ^ Log a problem that needs interventions by admins
|
||||
-- ^ Log a problem that needs interventions by admins, provided this problem has not already been reported and is still unsolved
|
||||
--
|
||||
-- - `problemLogTime` is now
|
||||
-- - `problemSolver` is Nothing, we do not record the person who caused it
|
||||
reportAdminProblem problem@(toJSON -> problemLogInfo) = do
|
||||
problemLogTime <- liftIO getCurrentTime
|
||||
reportAdminProblem problem = do
|
||||
let problemLogSolved = Nothing
|
||||
problemLogSolver = Nothing
|
||||
insert_ ProblemLog{..}
|
||||
problemLogInfo = toJSON problem
|
||||
problemLogTime <- liftIO getCurrentTime
|
||||
isKnown <- E.selectExists $ do
|
||||
pl <- E.from $ E.table @ProblemLog
|
||||
E.where_ $ E.isNothing (pl E.^. ProblemLogSolved)
|
||||
E.&&. E.val problemLogInfo E.==. pl E.^. ProblemLogInfo
|
||||
unless isKnown $ insert_ ProblemLog{..}
|
||||
$logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack)
|
||||
|
||||
|
||||
|
||||
@ -445,7 +445,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
|
||||
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
|
||||
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
|
||||
-- return pst_up
|
||||
upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo [usrId] -- ensure firmInfo superior is supervisor for this user
|
||||
upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId -- ensure firmInfo superior is supervisor for this user
|
||||
update usrId usr_up2 -- update user by company switch first (due to possible conflicts with usr_up2)
|
||||
update usrId usr_up1 -- update user eventually
|
||||
update uaId avs_ups -- update stored avsinfo for future updates
|
||||
@ -645,8 +645,8 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
||||
|
||||
|
||||
-- | adjust superiors, assumes that CompanyUser exists for all usrs for given company; does not work otherwise
|
||||
upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> [UserId] -> DB () -- may return superior (Maybe UserId), but currently not needed
|
||||
upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrs =
|
||||
upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> UserId -> DB () -- may return superior (Maybe UserId), but currently not needed
|
||||
upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrId =
|
||||
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
||||
getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
|
||||
newAvsNo = newAfi ^. _avsFirmFirmNo
|
||||
@ -655,22 +655,26 @@ upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi u
|
||||
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
|
||||
getSupervision :: Maybe UserId -> DB (Maybe (Entity UserSupervisor))
|
||||
getSupervision = traverseJoin (getBy . flip UniqueUserSupervisor usrId)
|
||||
unchangedCompany = oldAvsNo == Just newAvsNo
|
||||
changedSuperior = mbSupEmail /= mbOldEmail -- beware we only have AvsFirmInfo for one user; also both could be Nothing
|
||||
-- 1. not unchangedCompany: do not delete, but ensure that superior supervision is set, since it could be a just a single user company change
|
||||
-- 2. unchangedCompany && not changedSuperior: superior must already been set, short-circuit
|
||||
-- 3. unchangedCompany && changedSuperior: update superior for all users
|
||||
in unless (unchangedCompany && not changedSuperior) $ do -- do nothing if (unchangedCompany && not changedSuperior).
|
||||
mbSupId <- getSupId
|
||||
mbSupId <- getSupId
|
||||
mbUsrSup <- getSupervision mbSupId
|
||||
-- delete old superiors, if any
|
||||
when (unchangedCompany && changedSuperior) $
|
||||
deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
|
||||
[ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
|
||||
unless unchangedCompany $
|
||||
deleteWhere [ UserSupervisorReason ==. reasonSuperior, UserSupervisorUser <-. usrs ]
|
||||
deleteWhere [ UserSupervisorReason ==. reasonSuperior, UserSupervisorUser ==. usrId ]
|
||||
-- ensure superior supervision
|
||||
case mbSupId of
|
||||
Just supId -> do
|
||||
case (mbSupId, mbUsrSup) of
|
||||
(_ , Just _) -> return () -- supId is already supervisor for uid for any reason
|
||||
(Just supId, Nothing) -> 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
|
||||
@ -702,7 +706,7 @@ upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi u
|
||||
when (unchangedCompany && changedSuperior) $ do
|
||||
oldSupId <- getOldId
|
||||
reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
|
||||
Nothing ->
|
||||
(Nothing, Nothing) ->
|
||||
when (unchangedCompany && changedSuperior) $ do
|
||||
oldSupId <- getOldId
|
||||
reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
|
||||
|
||||
Loading…
Reference in New Issue
Block a user