From 8adcdf69fe673ebb88810e05402bff054270b024 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 12 Feb 2025 12:11:08 +0100 Subject: [PATCH] refactor(db): widen the type for DBRead for more flexibility also - change some AdminProblemR DB actions to DBRead instead - add insane supervision warning to AdminProblem page --- .../uniworx/categories/admin/de-de-formal.msg | 4 +- messages/uniworx/categories/admin/en-eu.msg | 4 +- src/Foundation/Navigation.hs | 16 ++++--- src/Foundation/Type.hs | 18 ++++++-- src/Handler/Admin.hs | 22 +++++---- src/Handler/Utils/Avs.hs | 4 +- src/Handler/Utils/Memcached.hs | 6 +-- src/Handler/Utils/Users.hs | 30 ++++++------ src/Utils/Company.hs | 46 +++++++++++++++++++ templates/admin-problems.hamlet | 7 ++- 10 files changed, 114 insertions(+), 43 deletions(-) create mode 100644 src/Utils/Company.hs diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index a80ceead2..143c3a1e1 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Winnie Ros ,Steffen Jost +# SPDX-FileCopyrightText: 2022-25 Gregor Kleen ,Winnie Ros ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -112,6 +112,7 @@ ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge #{pluralDE n "des vergangenen Tages" ("der vergangenen "<> tshow n <> " Tage")} wurden von der Druckerei bestätigt ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig +ProblemsNoInsaneCompanySupervisions: Sind alle Firmen-bezogenen Ansprechpartnerbeziehungen zwischen passenden Firmenangehörigen? ProblemsUnreachableHeading: Unerreichbare Benutzer ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können: ProblemsUnreachableButtons: Synchronisation für Unerreichbare starten @@ -123,6 +124,7 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit ProblemAvsUsrHadR: Momentan gültiges R im AVS +ProblemCheckOncePerDay: Prüfung nur einmal pro Tag AdminProblemSolved: Erledigt AdminProblemSolver: Bearbeitet von diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index f69fda9e5..772b1d6c2 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Winnie Ros ,Steffen Jost +# SPDX-FileCopyrightText: 2022-25 Sarah Vaupel ,Winnie Ros ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -112,6 +112,7 @@ ProblemsDriversHaveAvsIds: All driving licence holder could be matched with thei ProblemsUsersAreReachable: Either Email or postal address is known for all users ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{pluralENsN n "day"} were acknowledged as printed by the airport printing center ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit +ProblemsNoInsaneCompanySupervisions: All company related supervisions are between company-associated users ProblemsUnreachableHeading: Unreachable Users ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications: ProblemsUnreachableButtons: Start synchronisation for unreachable users only @@ -123,6 +124,7 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since ProblemAvsUsrHadR: Currenlt R valid in AVS +ProblemCheckOncePerDay: Checkd once per day AdminProblemSolved: Done AdminProblemSolver: Solved by diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 9448f70c3..c744ee42c 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -29,10 +29,12 @@ import Foundation.Routes import Foundation.I18n import Foundation.Authorization +import Utils.Company (areThereInsaneCompanySupervisions) +import Utils.Sheet + import Handler.Utils.DateTime import Handler.Utils.Memcached import Handler.Utils.ExamOffice.Course -import Utils.Sheet import qualified Data.Set as Set import qualified Data.Map as Map @@ -2458,12 +2460,12 @@ pageActions ApiDocsR = return , navChildren = [] } ] -pageActions FirmAllR = return - [ NavPageActionPrimary - { navLink = defNavLink MsgMenuFirmsSupervision FirmsSupervisionR - , navChildren = [] - } - ] +pageActions FirmAllR = do + let navLink = defNavLink MsgMenuFirmsSupervision FirmsSupervisionR + navChildren = [] + thereAre <- liftHandler areThereInsaneCompanySupervisions + return [ NavPageActionPrimary{..} | thereAre ] + pageActions (FirmUsersR fsh) = return [ NavPageActionPrimary { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index d254a2826..f2f84e7ce 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-26 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -13,7 +13,9 @@ module Foundation.Type , _memcachedKey, _memcachedConn , SMTPPool , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache, _appAvsQuery - , DB, DBRead, Form, MsgRenderer, MailM, DBFile + , DB + , DBRead, DBRead', DBReadUq, DBReadUq' + , Form, MsgRenderer, MailM, DBFile ) where import Import.NoFoundation @@ -105,9 +107,17 @@ instance HasCookieSettings RegisteredCookie UniWorX where instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings) -type DB = YesodDB UniWorX +type DB = YesodDB UniWorX -- ~ ReaderT SqlBackend (HandlerFor UniWorX) -type DBRead = ReaderT SqlReadBackend (HandlerFor UniWorX) +-- type DBRead = ReaderT SqlReadBackend (HandlerFor UniWorX) -- old, was too unflexible. Try DBRead first, then add suffixes ' or Uq until it types ;) +type DBRead a = forall backend . (PersistQueryRead backend, BackendCompatible SqlBackend backend) + => ReaderT backend (HandlerFor UniWorX) a +type DBRead' a = forall backend . (PersistQueryRead backend, BackendCompatible SqlBackend backend, BaseBackend backend ~ SqlBackend) -- ought to be redundant, but somehow isn´t. Using this everywhere give redundant constraint warnings, also undesirable + => ReaderT backend (HandlerFor UniWorX) a +type DBReadUq a = forall backend . (PersistQueryRead backend, BackendCompatible SqlBackend backend, PersistUniqueRead backend) -- adding this to DBRead would yield some unnecessary constraint warnings + => ReaderT backend (HandlerFor UniWorX) a +type DBReadUq' a = forall backend . (PersistQueryRead backend, BackendCompatible SqlBackend backend, BaseBackend backend ~ SqlBackend, PersistUniqueRead backend) + => ReaderT backend (HandlerFor UniWorX) a type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ()) type MsgRenderer = MsgRendererS UniWorX -- see Utils type MailM a = MailT (HandlerFor UniWorX) a diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index d19b90320..9ba424661 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -25,6 +25,7 @@ import qualified Database.Esqueleto.Legacy as EL (on) -- needed for dbTable import qualified Database.Esqueleto.Utils as E import Jobs +import Utils.Company (areThereInsaneCompanySupervisions) import Handler.Utils import Handler.Utils.Avs import Handler.Utils.Users @@ -79,13 +80,14 @@ handleAdminProblems mbProblemTable = do flagNonZero n | n <= 0 = flagError True | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) - (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,) + thereAreInsanceFirmSupervisions <- not <$> areThereInsaneCompanySupervisions -- cached for 22h + (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, not -> noStalePrintJobs, not -> noBadAPCids) <- runDBRead $ (,,,,) <$> areAllUsersReachable <*> allDriversHaveAvsId now <*> allRDriversHaveFs now - <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]) - <*> (not <$> exists [PrintAcknowledgeProcessed ==. False]) - <*> mkInterfaceLogTable mempty + <*> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime] + <*> exists [PrintAcknowledgeProcessed ==. False] + (interfaceOks, interfaceTable) <- runDB $ mkInterfaceLogTable mempty let interfacesBadNr = length $ filter (not . snd) interfaceOks -- interfacesOk = all snd interfaceOks @@ -141,7 +143,7 @@ postAdminProblemsR = do getProblemUnreachableR, postProblemUnreachableR :: Handler Html getProblemUnreachableR = postProblemUnreachableR postProblemUnreachableR = do - unreachables <- runDB retrieveUnreachableUsers + unreachables <- runDBRead retrieveUnreachableUsers -- the following form is a nearly identicaly copy from Handler.Users: ((noreachUsersRes, noreachUsersWgt'), noreachUsersEnctype) <- runFormPost . identifyForm FIDUnreachableUsersAction $ buttonForm @@ -215,7 +217,7 @@ mkUnreachableUsersTable = do dbtColonnade = -} -areAllUsersReachable :: DB Bool +areAllUsersReachable :: DBReadUq' Bool -- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone areAllUsersReachable = null <$> retrieveUnreachableUsers @@ -228,7 +230,7 @@ areAllUsersReachable = null <$> retrieveUnreachableUsers -- E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") -- return user -retrieveUnreachableUsers :: DB [Entity User] +retrieveUnreachableUsers :: DBReadUq' [Entity User] retrieveUnreachableUsers = do emailOnlyUsers <- E.select $ do user <- E.from $ E.table @User @@ -248,7 +250,7 @@ retrieveUnreachableUsers = do hasInvalidEmail = fmap isNothing . getUserEmail -allDriversHaveAvsId :: UTCTime -> DB Bool +allDriversHaveAvsId :: UTCTime -> DBReadUq Bool -- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId @@ -295,7 +297,7 @@ retrieveDriversWithoutAvsId now = do return usr -allRDriversHaveFs :: UTCTime -> DB Bool +allRDriversHaveFs :: UTCTime -> DBReadUq Bool -- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 1cd23055d..20d9937bb 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -960,7 +960,9 @@ getDifferingLicences (AvsResponseGetLicences licences) = do vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld' rollfeld = Set.map avsLicencePersonID rollfeld' - antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DBRead (Set AvsPersonId,Set AvsPersonId) + antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DBReadUq (Set AvsPersonId,Set AvsPersonId) + -- antijoinAvsLicences :: forall backend . (BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend) + -- => AvsLicence -> Set AvsPersonId -> ReaderT backend (HandlerFor UniWorX) (Set AvsPersonId,Set AvsPersonId) antijoinAvsLicences lic avsLics = fmap unwrapIds $ E.select $ do ((_qauli :& _qualUser :& usrAvs) :& excl) <- diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index d4193a82b..d6f455c16 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -63,18 +63,16 @@ import Data.Type.Equality (TestEquality(..)) import qualified Data.HashMap.Strict as HashMap +import Control.Concurrent.STM.Delay import qualified Control.Concurrent.TokenBucket as Concurrent (TokenBucket, newTokenBucket, tokenBucketTryAlloc) +import qualified Control.Monad.State.Class as State import System.IO.Unsafe (unsafePerformIO) -import Control.Concurrent.STM.Delay - import qualified Crypto.Saltine.Class as Saltine import qualified Crypto.Saltine.Internal.ByteSizes as Saltine import qualified Crypto.Saltine.Core.AEAD as AEAD -import qualified Control.Monad.State.Class as State - import qualified Data.ByteString.Lazy as Lazy (ByteString) import GHC.Fingerprint diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index bf9e13ed9..08eb19aff 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -1,8 +1,9 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-26 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -- NOTE: Also see Handler.Utils.Profile for similar utilities module Handler.Utils.Users @@ -78,12 +79,15 @@ abbrvName User{userDisplayName, userFirstName, userSurname} = -- Note: Entity can be recovered, since CompanyShort is also the key -getUserPrimaryCompany :: UserId -> DB (Maybe UserCompany) +-- getUserPrimaryCompany :: UserId -> DBRead (Maybe UserCompany) +-- getUserPrimaryCompany :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) => +-- UserId -> ReaderT backend m (Maybe UserCompany) +getUserPrimaryCompany :: UserId -> DBRead' (Maybe UserCompany) getUserPrimaryCompany uid = entityVal <<$>> selectFirst [UserCompanyUser ==. uid] [Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany] -getUserPrimaryCompanyAddress :: UserId -> (Company -> Maybe a) -> DB (Maybe a) +getUserPrimaryCompanyAddress :: UserId -> (Company -> Maybe a) -> DBRead' (Maybe a) getUserPrimaryCompanyAddress uid prj = runMaybeT $ do UserCompany{userCompanyCompany=cid, userCompanyUseCompanyAddress=True} <- MaybeT $ getUserPrimaryCompany uid -- return Nothing if company address is not to be used company <- MaybeT $ get cid @@ -93,7 +97,7 @@ getUserPrimaryCompanyAddress uid prj = runMaybeT $ do -- | Compute actual address for user; returning True for Postal preference, as well as address (user or company) and primary e-mail -- result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known -getPostalPreferenceAndAddress :: Entity User -> DB (Bool, Maybe [Text], Maybe UserEmail) +getPostalPreferenceAndAddress :: Entity User -> DBRead' (Bool, Maybe [Text], Maybe UserEmail) getPostalPreferenceAndAddress usr = do pa <- getPostalAddress usr em <- getUserEmail usr @@ -104,7 +108,7 @@ getPostalPreferenceAndAddress usr = do -- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known -- primed variant returns storedMarkup without prefixed userDisplayName -getPostalPreferenceAndAddress' :: Entity User -> DB (Bool, (Maybe StoredMarkup, Bool), (Maybe UserEmail, Bool)) +getPostalPreferenceAndAddress' :: Entity User -> DBReadUq' (Bool, (Maybe StoredMarkup, Bool), (Maybe UserEmail, Bool)) getPostalPreferenceAndAddress' usr = do pa <- getPostalAddress' usr em <- getUserEmailAutomatic usr @@ -113,20 +117,20 @@ getPostalPreferenceAndAddress' usr = do -- finalPref = isJust (fst pa) && (usrPrefPost || isNothing (fst em)) return (finalPref, pa, em) -getEmailAddressFor :: UserId -> DB (Maybe Address) +getEmailAddressFor :: UserId -> DBRead' (Maybe Address) getEmailAddressFor = maybeM (return Nothing) getEmailAddress . getEntity -getJustEmailAddressFor :: UserId -> DB Address +getJustEmailAddressFor :: UserId -> DBRead' Address getJustEmailAddressFor = maybeThrowM ExceptionUserHasNoEmail . getEmailAddressFor -getJustEmailAddress :: Entity User -> DB Address +getJustEmailAddress :: Entity User -> DBRead' Address getJustEmailAddress = maybeThrowM ExceptionUserHasNoEmail . getEmailAddress -getEmailAddress :: Entity User -> DB (Maybe Address) +getEmailAddress :: Entity User -> DBRead' (Maybe Address) getEmailAddress usr@Entity{entityVal=User{userDisplayName}} = toAddress <<$>> getUserEmail usr where toAddress = Address (Just userDisplayName) . CI.original -getUserEmail :: Entity User -> DB (Maybe UserEmail) +getUserEmail :: Entity User -> DBRead' (Maybe UserEmail) getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}} | validEmail' userDisplayEmail = return $ Just userDisplayEmail @@ -136,7 +140,7 @@ getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}} return $ pickValidEmail' $ mcons compEmailMb [userEmail] -- like `getUserEmail`, but also checks whether the Email will be update automatically -getUserEmailAutomatic :: Entity User -> DB (Maybe UserEmail, Bool) +getUserEmailAutomatic :: Entity User -> DBReadUq' (Maybe UserEmail, Bool) getUserEmailAutomatic Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}} | validEmail' userDisplayEmail = do @@ -151,7 +155,7 @@ getUserEmailAutomatic Entity{entityKey=uid, entityVal=User{userDisplayEmail, use _ -> return (Nothing , False) -- address is prefixed with userDisplayName -getPostalAddress :: Entity User -> DB (Maybe [Text]) +getPostalAddress :: Entity User -> DBRead' (Maybe [Text]) getPostalAddress Entity{entityKey=uid, entityVal=User{..}} | (Just upo) <- userPostAddress, validPostAddress userPostAddress = prefixMarkupName upo @@ -169,7 +173,7 @@ getPostalAddress Entity{entityKey=uid, entityVal=User{..}} prefixMarkupName = return . Just . (userDisplayName :) . html2textlines -- primed variant returns storedMarkup without prefixed userDisplayName and whether updates are automatic -getPostalAddress' :: Entity User -> DB (Maybe StoredMarkup, Bool) +getPostalAddress' :: Entity User -> DBReadUq' (Maybe StoredMarkup, Bool) getPostalAddress' Entity{entityKey=uid, entityVal=User{..}} | validPostAddress userPostAddress = do diff --git a/src/Utils/Company.hs b/src/Utils/Company.hs new file mode 100644 index 000000000..4eb7eea05 --- /dev/null +++ b/src/Utils/Company.hs @@ -0,0 +1,46 @@ +-- SPDX-FileCopyrightText: 2025 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Utils.Company where + +import Import.NoFoundation +import Foundation.Type +import Foundation.DB + +-- import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.PostgreSQL as E + +import Handler.Utils.Memcached + + +-- DB Queries related to firms and supervision that are used in several places + + +-- | check if a user is NOT associated with a company; false if company is null +usrDoesNotBelong :: E.SqlExpr (E.Value UserId) -> E.SqlExpr (E.Value (Maybe CompanyId)) -> E.SqlExpr (E.Value Bool) +usrDoesNotBelong uid fsh = E.isJust fsh E.&&. E.notExists (do + uc <- E.from $ E.table @UserCompany + E.where_ $ uc E.^. UserCompanyUser E.==. uid + E.&&. uc E.^. UserCompanyCompany E.=?. fsh + ) + +-- | given a supervisionship, true if supervisor is NOT associated with the supervisionship-company +missingCompanySupervisor :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool) +missingCompanySupervisor us = (us E.^. UserSupervisorSupervisor) `usrDoesNotBelong` (us E.^. UserSupervisorCompany) + +-- | given a supervisionship, true if subordinate is NOT associated with the supervisionship-company +missingCompanySubordinate :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool) +missingCompanySubordinate us = (us E.^. UserSupervisorUser) `usrDoesNotBelong` (us E.^. UserSupervisorCompany) + +-- | once per day, check if there are supervisionships where supervisor or subordinate are not associated witht the supervisionship-company +areThereInsaneCompanySupervisions :: HandlerFor UniWorX Bool +areThereInsaneCompanySupervisions = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-company-supervision|] $ do + res <- runDBRead $ E.selectExists $ do + us <- E.from $ E.table @UserSupervisor + E.where_ $ E.isJust (us E.^. UserSupervisorCompany) + E.&&. (missingCompanySupervisor us E.||. missingCompanySubordinate us) + $logInfoS "sanity" [st|Are there insane company supervisions: #{tshow res}|] + return res diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index 85701ef5a..80fb867b0 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -1,6 +1,6 @@ $newline never -$# SPDX-FileCopyrightText: 2022-24 Steffen Jost +$# SPDX-FileCopyrightText: 2022-25 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later @@ -28,7 +28,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
^{simpleLinkI MsgProblemsDriverSynch1up ProblemAvsSynchR}
^{flagNonZero ok0} -
^{simpleLinkI MsgProblemsDriverSynch0 ProblemAvsSynchR} +
^{simpleLinkI MsgProblemsDriverSynch0 ProblemAvsSynchR} (_{MsgProblemCheckOncePerDay})
^{flagWarning rDriversHaveFs}
^{simpleLinkI MsgProblemsRDriversHaveFs ProblemFbutNoR} @@ -52,6 +52,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
^{flagWarning False}
_{MsgMailRerouteTo reroute} +
^{flagError thereAreInsanceFirmSupervisions} +
^{simpleLinkI MsgProblemsNoInsaneCompanySupervisions FirmsSupervisionR} +

_{MsgMenuInterfaces}