refactor(admin): problem caching indicator made human readable

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

@@ -109,7 +109,7 @@ ProblemsDriverSynch1up: Alle gültigen Vorfeld-Fahrberechtigungen 'F' sind im AV
 ProblemsDriverSynch2: Alle gültigen Rollfeld-Fahrberechtigungen 'R' sind im AVS eingetragen
 ProblemsRDriversHaveFs: Alle Inhaber einer Rollfeld-Fahrberechtigung besitzen auch eine gültige Vorfeld-Fahrberechtigung
 ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS Identifikationsnummer zugeordnet werden
-ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt 
+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?
@@ -124,7 +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
+ProblemLastCheckTime t@Text: Letzte Prüfung vor #{t}
 
 AdminProblemSolved: Erledigt
 AdminProblemSolver: Bearbeitet von

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

@@ -124,7 +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
+ProblemLastCheckTime t: Last checked #{t} ago
 
 AdminProblemSolved: Done
 AdminProblemSolver: Solved by

src/Foundation/Navigation.hs

@@ -2486,7 +2486,7 @@ pageActions ApiDocsR = return
 pageActions FirmAllR = do
   let navLink     = defNavLink MsgMenuFirmsSupervision FirmsSupervisionR
       navChildren = []
-  thereAre <- liftHandler areThereInsaneCompanySupervisions
+  (thereAre,_) <- liftHandler areThereInsaneCompanySupervisions
   return [ NavPageActionPrimary{..} | thereAre ]
 
 pageActions (FirmUsersR fsh) = return

src/Handler/Admin.hs

@@ -80,10 +80,14 @@ handleAdminProblems mbProblemTable = do
       flagNonZero n | n <= 0    = flagError True
                     | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
 
-  thereAreInsanceFirmSupervisions <- not <$> areThereInsaneCompanySupervisions -- cached for 22h
+      showDiffTime t =
-  (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, not -> noStalePrintJobs, not -> noBadAPCids) <- runDBRead $ (,,,,)
+        let d = diffUTCTime now t
-      <$> areAllUsersReachable
+        in guardMonoid (d > secondsToNominalDiffTime 30) [whamlet|<small>_{MsgProblemLastCheckTime (formatDiffDays d)}|]
-      <*> allDriversHaveAvsId now
+
+  (usersAreReachable, aurTime) <- areAllUsersReachable -- cached
+  (not -> thereAreInsaneFirmSupervisions, ifsTime) <- areThereInsaneCompanySupervisions -- cached
+  (driversHaveAvsIds, rDriversHaveFs, not -> noStalePrintJobs, not -> noBadAPCids) <- runDBRead $ (,,,)
+      <$> allDriversHaveAvsId now
       <*> allRDriversHaveFs now
       <*> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime]
       <*> exists [PrintAcknowledgeProcessed ==. False]
@@ -217,9 +221,13 @@ mkUnreachableUsersTable = do
       dbtColonnade =
 -}
 
-areAllUsersReachable :: DBReadUq' Bool
+areAllUsersReachable :: Handler (Bool, UTCTime)
--- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone
+areAllUsersReachable = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-users-reachable|] $ do
-areAllUsersReachable = null <$> retrieveUnreachableUsers
+  now <- liftIO getCurrentTime
+  res <- runDBRead retrieveUnreachableUsers
+  -- res <- E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone
+  $logInfoS "sanity" [st|Are there insane company supervisions: #{tshow res}|]
+  return (null res,now)
 
 -- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User))
 -- retrieveUnreachableUsers' = do

src/Handler/Health.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-25 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -7,7 +7,7 @@ module Handler.Health where
 import Import
 
 import Data.Time.Format.ISO8601 (iso8601Show)
-import Handler.Utils.DateTime (formatTimeW)
+import Handler.Utils.DateTime (formatTimeW, formatDiffDays)
 
 import qualified Data.Aeson.Encode.Pretty as Aeson
 import qualified Data.Text.Lazy.Builder as Builder
@@ -127,6 +127,9 @@ getStatusR = do
             then tshow tdiff
             else pack . iso8601Show . calendarTimeTime . fromIntegral $ truncate tdiff
 
+      diffTime2 :: UTCTime -> Text
+      diffTime2 = formatDiffDays . diffUTCTime currtime
+
   withUrlRenderer
     [hamlet|
       $doctype 5
@@ -148,11 +151,11 @@ getStatusR = do
           <p>
             Instance Start <br>
             #{show starttime} #
-            Uptime: #{diffTime starttime}
+            Uptime: #{diffTime starttime} ~ #{diffTime2 starttime}
           <p>
             Compile Time <br>
             #{show cTime} #
-            Build age: #{diffTime cTime}
+            Build age: #{diffTime cTime} ~ #{diffTime2 cTime}
     |]
   where
     -- vnr_full :: Text = $(embedStringFile "nix/docker/version.json") -- nix/ files not accessible during container construction

src/Utils/Company.hs

@@ -36,11 +36,12 @@ missingCompanyClient :: E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value
 missingCompanyClient us = (us E.^. UserSupervisorUser) `usrDoesNotBelong` (us E.^. UserSupervisorCompany)
 
 -- | once per day, check if there are supervisionships where supervisor or client are not associated witht the supervisionship-company
-areThereInsaneCompanySupervisions :: HandlerFor UniWorX Bool
+areThereInsaneCompanySupervisions :: HandlerFor UniWorX (Bool, UTCTime)
 areThereInsaneCompanySupervisions = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-company-supervision|] $ do
+  now <- liftIO getCurrentTime
   res <- runDBRead $ E.selectExists $ do
     us <- E.from $ E.table @UserSupervisor
     E.where_ $ E.isJust (us E.^. UserSupervisorCompany)
         E.&&. (missingCompanySupervisor us E.||. missingCompanyClient us)
   $logInfoS "sanity" [st|Are there insane company supervisions: #{tshow res}|]
-  return res
+  return (res,now)

templates/admin-problems.hamlet

@@ -22,13 +22,13 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         <dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch2 ProblemAvsSynchR}
 
         <dt .deflist__dt>^{flagNonZero ok1down}
-        <dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch1down ProblemAvsSynchR}    
+        <dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch1down ProblemAvsSynchR}
 
         <dt .deflist__dt>^{flagNonZero ok1up}
         <dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch1up ProblemAvsSynchR}
 
         <dt .deflist__dt>^{flagNonZero ok0}
-        <dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch0 ProblemAvsSynchR} (_{MsgProblemCheckOncePerDay})
+        <dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch0 ProblemAvsSynchR}
 
     <dt .deflist__dt>^{flagWarning rDriversHaveFs}
     <dd .deflist__dd>^{simpleLinkI MsgProblemsRDriversHaveFs ProblemFbutNoR}
@@ -40,7 +40,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
   <dl .deflist>
     <dt .deflist__dt>^{flagError usersAreReachable}
-    <dd .deflist__dd>^{simpleLinkI MsgProblemsUsersAreReachable ProblemUnreachableR}
+    <dd .deflist__dd>^{simpleLinkI MsgProblemsUsersAreReachable ProblemUnreachableR} ^{showDiffTime aurTime}
 
     <dt .deflist__dt>^{flagError noStalePrintJobs}
     <dd .deflist__dd>^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffOldDays) PrintCenterR}
@@ -48,8 +48,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
     <dt .deflist__dt>^{flagError noBadAPCids}
     <dd .deflist__dd>_{MsgProblemsNoBadAPCIds}
 
-    <dt .deflist__dt>^{flagError thereAreInsanceFirmSupervisions}
+    <dt .deflist__dt>^{flagError thereAreInsaneFirmSupervisions}
-    <dd .deflist__dd>^{simpleLinkI MsgProblemsNoInsaneCompanySupervisions FirmsSupervisionR}
+    <dd .deflist__dd>^{simpleLinkI MsgProblemsNoInsaneCompanySupervisions FirmsSupervisionR} ^{showDiffTime ifsTime}
     
     $maybe reroute <- rerouteMail
       <dt .deflist__dt>^{flagWarning False}