chore(avs): add debug log info after not finding an error in company supervision switching after avs update

src/Handler/Utils/Avs.hs

@@ -411,26 +411,29 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
               base_up :: [Update User]
               base_up = guardMonoid (newCompanyEnt ^. _entityVal . _companyPinPassword) (maybeToList pin_up0)
 
-
           case oldAvsFirmInfo of
             _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
-                -> return base_up                                                               --  => do nothing
+                -> do                                                                           --  => do nothing
+                    $logInfoS "Supervision" [st|updateAvsUserByADC for #{tshow usrId} to new company #{unCompanyKey newCompanyId} from old company #{oldCompanyId} having primary company #{primaryCompanyId}. Company id unchanged.|]
+                    return base_up
             (Just oafi) |  isJust    (view _avsFirmPostAddressSimple  oafi)
                         && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo       -- non-empty company address unchanged OR
                         || isJust    (view _avsFirmPrimaryEmail       oafi)
                         && ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo       -- non-empty company primary email unchanged
                 -> do                                                                           --  => just update user company association, keeping supervision privileges
+                    $logInfoS "Supervision" [st|updateAvsUserByADC for #{tshow usrId} to new company #{unCompanyKey newCompanyId} from old company #{oldCompanyId} having primary company #{primaryCompanyId}. Company address unchanged, just updating.|]
                     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)  -- keep default supervisor settings
                         void $ updateWhere [ UserSupervisorSupervisor ==. usrId                                               -- update company-related supervisions
-                                          , UserSupervisorCompany ==. Just ocid                                              -- to new company, regardless of
+                                           , UserSupervisorCompany ==. Just ocid                                              -- to new company, regardless of
-                                          , UserSupervisorReason ==. Just superReasonComDef]                                 -- user
+                                           , UserSupervisorReason ==. Just superReasonComDef]                                 -- user
-                                          [ UserSupervisorCompany =. Just newCompanyId]
+                                           [ UserSupervisorCompany =. Just newCompanyId]
                     return base_up
             _ | Just newCompanyId == primaryCompanyId                                           -- old primaryCompany is now also AVS-company
                 -> do
+                    $logInfoS "Supervision" [st|updateAvsUserByADC for #{tshow usrId} to new company #{unCompanyKey newCompanyId} from old company #{oldCompanyId} having primary company #{primaryCompanyId}. Primary company unchanged.|]
                     whenIsJust oldCompanyId $ \oldCid -> do
                       deleteBy $ UniqueUserCompany usrId oldCid
                       deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
@@ -438,6 +441,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
             _                                                                                   -- company changed completely
                 -> do
                     (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
+                    $logInfoS "Supervision" [st|updateAvsUserByADC for #{tshow usrId} to new company #{unCompanyKey newCompanyId} from old company #{oldCompanyId} having primary company #{primaryCompanyId}. Company switched. #{length pst_up} updates. #{length problems} problems.|]
                     mapM_ reportAdminProblem problems
                     -- Following line does not type, hence additional parameter needed
                     -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
@@ -715,11 +719,11 @@ upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi u
               E.<&> E.justVal cid
               E.<&> E.val reasonSuperior
           )
-          (\_old _new -> [] -- do not change exisitng supervision
+          (\_old new ->
-            -- [ UserSupervisorCompany               E.=. new E.^. UserSupervisorCompany
+            [ UserSupervisorCompany               E.=. new E.^. UserSupervisorCompany
-            -- , UserSupervisorReason                E.=. new E.^. UserSupervisorReason
+            , UserSupervisorReason                E.=. new E.^. UserSupervisorReason
-            -- , UserSupervisorRerouteNotifications  E.=. new E.^. UserSupervisorRerouteNotifications
+            , UserSupervisorRerouteNotifications  E.=. new E.^. UserSupervisorRerouteNotifications
-            -- ]
+            ]
           )
         when (unchangedCompany && changedSuperior) $ do
           oldSupId <- getOldId

src/Handler/Utils/Company.hs

@@ -38,6 +38,11 @@ instance E.SqlString (Key Company)
 company2msg :: CompanyId -> SomeMessage UniWorX
 company2msg = text2message . ciOriginal . unCompanyKey
 
+-- for convenience in debugging
+instance ToText (Maybe CompanyId) where
+  toText Nothing    = toText ("-None-"::Text)
+  toText (Just fsh) = toText $ unCompanyKey fsh
+
 wgtCompanies :: Bool -> UserId -> DB (Maybe Widget)
 wgtCompanies useShort = (wrapUL . fst <<$>>) . wgtCompanies' useShort
   where
@@ -104,7 +109,8 @@ addDefaultSupervisors reason cid employees = do
       [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
       , UserSupervisorCompany E.=. E.justVal cid
       , UserSupervisorReason  E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
-      ])
+      ]
+    )
 
 
 -- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
@@ -164,7 +170,7 @@ addDefaultSupervisorsAll reason mutualSupervision cids = do
         , UserSupervisorReason  E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
         ] )
 
--- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet
+-- | removes user supervisorship on switch. WARNING: problems are only returned, but not yet written to DB via reportProblem
 switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
 switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do
     usrRec      <- get404 uid
@@ -193,14 +199,16 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
     case mbUsrComp of
       Nothing -> do -- create company user
         void $ insertUnique newUserComp
-        void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
+        newAPs <- addDefaultSupervisors' newCompanyId $ singleton uid
+        $logInfoS "Supervision" [st|switchAvsUserCompany for #{tshow uid} to #{unCompanyKey newCompanyId}. #{newAPs} default company supervisors upserted.|]
         return (usrUpdate, mempty)
       Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
         | newCompanyId == oldCompanyId -> return mempty -- nothing to do
         | otherwise -> do -- switch company
             when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
-            void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = succ oldPrio}
+            let newPrio = succ oldPrio
-              [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
+            void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp{userCompanyPriority = newPrio}
+              [UserCompanyPriority =. newPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
             -- supervised by uid
             supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
               usrSup <- E.from $ E.table @UserSupervisor
@@ -220,17 +228,19 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
               return $  [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute
                         | (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True)  <- supervisees ]
             -- supervisors of uid
-            let superDeftFltr     = (UserSupervisorUser ==. uid) : (UserSupervisorReason  ~=. superReasonComDef)
+            let superDeftFltr     = (UserSupervisorUser ==. uid) : (UserSupervisorReason  ~=. superReasonComDef)  -- default or no reason
-                oldSubFltr        = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr
+                oldSubFltr        = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr                     -- old company or no company
             oldAPs <- if keepOldCompanySupervs
               then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
               else deleteWhereCount oldSubFltr
-            void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
+            nrDefSups <- addDefaultSupervisors' newCompanyId $ singleton uid -- CHECK HERE WITH LINES ABOVE
             newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
             let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
                 problems = bcons oldSuper             (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
                          $ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
                            newlyUnsupervised
+                delupd = bool "deleted" "updated" keepOldCompanySupervs :: Text
+            $logInfoS "Supervision" [st|switchAvsUserCompany for #{tshow uid} from #{unCompanyKey oldCompanyId} to #{unCompanyKey newCompanyId}. #{oldAPs} old APs #{delupd}. #{nrDefSups} default company supervisors upserted. #{newAPs} new company supervisors counted now.|]
             return (usrUpdate ,problems)
 
 defaultSupervisorReasonFilter :: [Filter UserSupervisor]

src/Handler/Utils/Users.hs

@@ -78,10 +78,9 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
     assemble = Text.intercalate "."
 
 
--- Note: Entity can be recovered, since CompanyShort is also the key
+-- | Retrieve primary company association for user.
--- getUserPrimaryCompany :: UserId -> DBRead (Maybe UserCompany)
+-- Warning: if there are multiple associations witht the same priority, one with rerouting and supervision are preferred, them alphabetically
--- getUserPrimaryCompany :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) =>
+-- Note that Entity Company can be retrieved, since CompanyShorthand is the DB key.
---                           UserId -> ReaderT backend m (Maybe UserCompany)
 getUserPrimaryCompany :: UserId -> DBRead' (Maybe UserCompany)
 getUserPrimaryCompany uid = entityVal <<$>>
   selectFirst [UserCompanyUser ==. uid]