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

@@ -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
+reportAdminProblem problem = do
-  problemLogTime <- liftIO getCurrentTime
   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)
 
 

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 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{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
+      getSupervision :: Maybe UserId -> DB (Maybe (Entity UserSupervisor))
-      changedSuperior   = mbSupEmail /= mbOldEmail     -- beware, both could be Nothing
+      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
+    case (mbSupId, mbUsrSup) of
-      Just supId -> do
+      (_          , 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