fix(avs): fix #225 by skipping firm updates entirely if AVS FirmInfo is unchanged for previously seen values for AVS User to be updated

Note: noticed while working on #225

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
@@ -178,15 +182,20 @@ reportAdminProblem ::  ( IsSqlBackend (YesodPersistBackend (HandlerSite m))
                   )
       => 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

@@ -329,6 +329,8 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
       let usrId = userAvsUser usravs
       usr <- MaybeT $ get usrId
       lift $ do -- maybeT no longer needed from here onwards
+        uuid :: CryptoUUIDUser <- encrypt usrId
+        $logInfoS "AVS" [st|updateAvsUserByADC: #{tshow uuid}|]
         let oldAvsPersonInfo  = userAvsLastPersonInfo usravs   -- Nothing is ok here
             oldAvsFirmInfo    = userAvsLastFirmInfo   usravs   -- Nothing is ok here
             oldAvsCardNo      = userAvsLastCardNo     usravs & fmap Just
@@ -380,8 +382,10 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
                       , UserAvsLastCardNo     =. newAvsCardNo
                       ]
 
+        usr_up2 <- guardMonoidM (oldAvsFirmInfo /= Just newAvsFirmInfo) $ do
           -- update company association & supervision
           newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
+          upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId   -- ensure firmInfo superior is supervisor for this user
           oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
           primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
           let oldCompanyId = entityKey <$> oldCompanyEnt
@@ -398,7 +402,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
               superReasonComDef = tshow SupervisorReasonCompanyDefault
               newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
 
-        usr_up2 <- case oldAvsFirmInfo of
+          case oldAvsFirmInfo of
             _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
                 -> return mempty                                                                --  => do nothing
             (Just oafi) |  isJust    (view _avsFirmPostAddressSimple  oafi)
@@ -445,7 +449,6 @@ 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
         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
@@ -585,16 +588,18 @@ getAvsCompany afi =
 
 -- | insert a company from AVS firm info or update an existing one based on previous values
 upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
+-- upsertAvsCompany newAvsFirmInfo (Just oldAvsFirmInfo)
+--   | newAvsFirmInfo == oldAvsFirmInfo = maybeM (upsertAvsCompany newAvsFirmInfo Nothing) pure $ getAvsCompany newAvsFirmInfo  -- firmInfo unchanged, shortcircuit; SHORTCIRCUIT no longer needed, checked at call-site due to result not being wrapped in Maybe
 upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
     mbFirmEnt <- getAvsCompany newAvsFirmInfo --  primarily by AvsId, then Shorthand, then name
-    $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
+    $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbOldAvsFirmInfo} new #{tshow newAvsFirmInfo} ent-new #{tshow mbFirmEnt}|]
-    case (mbFirmEnt, mbOldAvsFirmInfo) of
+    case mbFirmEnt of
-      (Nothing, _) -> do                                                                                  -- insert new company, neither AvsId nor Shorthand exist in DB
+      Nothing -> do                                                                                  -- insert new company, neither AvsId nor Shorthand exist in DB
         afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
                 then return $ newAvsFirmInfo ^. _avsFirmFirmNo
                 else maybe (-1) (pred . companyAvsId . entityVal) <$> selectMaybe [CompanyAvsId <. 0] [Asc CompanyAvsId]
         let upd  = flip updateRecord newAvsFirmInfo
-            dmy = Company                                                                                 -- mostly dummy, values are actually prodcued through firmInfo2company below for consistency
+            dmy = Company                                                                            -- mostly dummy, values are actually produced through firmInfo2company below for consistency
                   { companyName           = newAvsFirmInfo ^. _avsFirmFirm          . from _CI
                   , companyShorthand      = newAvsFirmInfo ^. _avsFirmAbbreviation  . from _CI
                   , companyAvsId          = afn
@@ -606,11 +611,12 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
         $logInfoS "AVS" $ "Insert new company: " <> tshow cmp
         newCmp <- insertEntity cmp
         reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
-        $logInfoS "AVS" "Insert new company completed."
         return newCmp
 
-      (Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do                               -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
+      (Just Entity{entityKey=firmid, entityVal=firm}) -> do                                          -- possibly update existing company, if isJust oldAvsFirmInfo and identical AvsFirmNo and changes occurred
-        let cmp_ups = mapMaybe  (mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
+        let oldHasSameFirmNo = Just (newAvsFirmInfo ^. _avsFirmFirmNo) == (mbOldAvsFirmInfo ^? _Just . _avsFirmFirmNo)
+            oldAvsFirmInfo = guardOnM oldHasSameFirmNo mbOldAvsFirmInfo
+            cmp_ups = mapMaybe  (mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
             key_ups =            mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo  firmInfo2key
         uniq_ups    <-           mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo  firmInfo2companyNo
         $logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow oldAvsFirmInfo}|]
@@ -629,7 +635,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
                | otherwise -> $logInfoS "AVS" $ "Update company shorthand failed for " <> ciOriginal cmp_key <> " and " <> ciOriginal alt_key
             maybeM (return res_cmp) return $ getBy uniq_cmp
           _otherwise -> return res_cmp
-        $logInfoS "AVS" "Update company completed."
+        $logInfoS "AVS" [st|Update company #{companyShorthand firm} completed.|]
         return res_cmp2
   where
     firmInfo2key =
@@ -645,8 +651,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 +661,26 @@ upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi u
       mbOldEmail  = oldAfi ^? _Just . _avsFirmEMailSuperior . _Just
       getSupId    =  getInsertUid                `traverseJoin` mbSupEmail
       getOldId    = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail
+      getSupervision :: Maybe UserId -> DB (Maybe (Entity UserSupervisor))
+      getSupervision = traverseJoin (getBy . flip UniqueUserSupervisor usrId)
       unchangedCompany = oldAvsNo   == Just newAvsNo
-      changedSuperior   = mbSupEmail /= mbOldEmail     -- beware, both could be Nothing
+      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
+    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 +712,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

src/Jobs/Handler/SynchroniseAvs.hs

@@ -122,11 +122,11 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
       -- E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
       -- return jobs
     let (unlinked, linked) = foldl' discernJob mempty jobs
-    $logInfoS "SynchronisAvs" [st|AVS synch performing for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
+    $logInfoS "SynchronisAvs" [st|AVS synch start for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
     void $ updateAvsUserByIds  linked
     void $ linktoAvsUserByUIDs unlinked
     runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)]
-    $logInfoS "SynchronisAvs" [st|AVS synch performed for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
+    $logInfoS "SynchronisAvs" [st|AVS synch end for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
     -- we do not reschedule failed synchs here in order to avoid a loop
   where
     discernJob accs (         _ , E.Value (Just api), E.Value True  ) = accs & over _2 (Set.insert api)