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

messages/uniworx/categories/admin/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
+# SPDX-FileCopyrightText: 2022-25 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 #
 # 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

messages/uniworx/categories/admin/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
+# SPDX-FileCopyrightText: 2022-25 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 #
 # 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

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
+pageActions FirmAllR = do
-  [ NavPageActionPrimary
+  let navLink     = defNavLink MsgMenuFirmsSupervision FirmsSupervisionR
-    { navLink = defNavLink MsgMenuFirmsSupervision FirmsSupervisionR
+      navChildren = []
-    , navChildren = []
+  thereAre <- liftHandler areThereInsaneCompanySupervisions
-    }
+  return [ NavPageActionPrimary{..} | thereAre ]
-  ]
+
 pageActions (FirmUsersR fsh) = return
   [ NavPageActionPrimary
     { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh

src/Foundation/Type.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-26 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- 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

src/Handler/Admin.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-25 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- 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])
+      <*> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime]
-      <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
+      <*> exists [PrintAcknowledgeProcessed ==. False]
-      <*> mkInterfaceLogTable mempty
+  (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
 

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) <-

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

src/Handler/Utils/Users.hs

@@ -1,8 +1,9 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-26 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- 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

src/Utils/Company.hs

@@ -0,0 +1,46 @@
+-- SPDX-FileCopyrightText: 2025 Steffen Jost <s.jost@fraport.de>
+--
+-- 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

templates/admin-problems.hamlet

@@ -1,6 +1,6 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>
+$# SPDX-FileCopyrightText: 2022-25 Steffen Jost <s.jost@fraport.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -28,7 +28,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         <dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch1up ProblemAvsSynchR}
 
         <dt .deflist__dt>^{flagNonZero ok0}
-        <dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch0 ProblemAvsSynchR}    
+        <dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch0 ProblemAvsSynchR} (_{MsgProblemCheckOncePerDay})
 
     <dt .deflist__dt>^{flagWarning rDriversHaveFs}
     <dd .deflist__dd>^{simpleLinkI MsgProblemsRDriversHaveFs ProblemFbutNoR}
@@ -52,6 +52,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
       <dt .deflist__dt>^{flagWarning False}
       <dd .deflist__dd>_{MsgMailRerouteTo reroute}
 
+    <dt .deflist__dt>^{flagError thereAreInsanceFirmSupervisions}
+    <dd .deflist__dd>^{simpleLinkI MsgProblemsNoInsaneCompanySupervisions FirmsSupervisionR}
+
 <section>
   <h2>
     _{MsgMenuInterfaces}