From 3960931bb5be6d467a54beec6718d409d7787651 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 8 Oct 2024 17:47:46 +0200 Subject: [PATCH] fix(avs): fix #224 repeated superior changes no longer occur furthermore AdminProblems are only inserted if the same problem does not exist unsolved --- src/Audit.hs | 25 +++++++++++++++++-------- src/Handler/Utils/Avs.hs | 24 ++++++++++++++---------- 2 files changed, 31 insertions(+), 18 deletions(-) diff --git a/src/Audit.hs b/src/Audit.hs index 06c5ca3d6..8bff261b3 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen ,Steffen Jost -- -- 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) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 8981772e9..261dea6b9 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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