From 0fa70b6e1fb3ab610363f2f70c4098d455768dfd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 14 Feb 2025 17:01:54 +0100 Subject: [PATCH] refactor(admin): problem caching indicator made human readable --- .../uniworx/categories/admin/de-de-formal.msg | 4 ++-- messages/uniworx/categories/admin/en-eu.msg | 2 +- src/Foundation/Navigation.hs | 2 +- src/Handler/Admin.hs | 22 +++++++++++++------ src/Handler/Health.hs | 11 ++++++---- src/Utils/Company.hs | 5 +++-- templates/admin-problems.hamlet | 10 ++++----- 7 files changed, 34 insertions(+), 22 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 143c3a1e1..a6edf0fdb 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 772b1d6c2..1724bd06f 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index d7adc06b9..87fba1772 100644 --- a/src/Foundation/Navigation.hs +++ b/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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 9ba424661..8f31f69bb 100644 --- a/src/Handler/Admin.hs +++ b/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 - (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, not -> noStalePrintJobs, not -> noBadAPCids) <- runDBRead $ (,,,,) - <$> areAllUsersReachable - <*> allDriversHaveAvsId now + showDiffTime t = + let d = diffUTCTime now t + in guardMonoid (d > secondsToNominalDiffTime 30) [whamlet|_{MsgProblemLastCheckTime (formatDiffDays d)}|] + + (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 = E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone -areAllUsersReachable = null <$> retrieveUnreachableUsers +areAllUsersReachable :: Handler (Bool, UTCTime) +areAllUsersReachable = $(memcachedByHere) (Just . Right $ 22 * diffHour) [st|isane-users-reachable|] $ do + 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 diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index 708feea8f..a92d88270 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-25 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- 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

Instance Start
#{show starttime} # - Uptime: #{diffTime starttime} + Uptime: #{diffTime starttime} ~ #{diffTime2 starttime}

Compile Time
#{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 diff --git a/src/Utils/Company.hs b/src/Utils/Company.hs index 57295701e..f79c2fff4 100644 --- a/src/Utils/Company.hs +++ b/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) diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index d07b2715e..8c99c2b6d 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -22,13 +22,13 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

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