From 407ba543a1a0ae6cf1508de4d749f29642cb5914 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 21 Aug 2024 17:34:19 +0200 Subject: [PATCH] chore(health): fix #154 by adding interface warning threshold edit handler --- .../uniworx/categories/admin/de-de-formal.msg | 8 +- messages/uniworx/categories/admin/en-eu.msg | 8 +- routes | 1 + src/Foundation/Navigation.hs | 15 ++ src/Handler/Health/Interface.hs | 145 +++++++++++++++++- src/Handler/Utils/DateTime.hs | 26 ++-- src/Utils/Lens.hs | 1 + templates/admin-problems.hamlet | 6 +- .../config-interfaces/de-de-formal.hamlet | 41 +++++ templates/i18n/config-interfaces/en-eu.hamlet | 36 +++++ 10 files changed, 270 insertions(+), 17 deletions(-) create mode 100644 templates/i18n/config-interfaces/de-de-formal.hamlet create mode 100644 templates/i18n/config-interfaces/en-eu.hamlet diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index e24dcad0b..3bf0ac7a5 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -149,4 +149,10 @@ InterfaceSubtype: Betreffend InterfaceWrite: Schreibend InterfaceSuccess: Rückmeldung InterfaceInfo: Nachricht -InterfaceFreshness: Prüfungszeitraum (h) \ No newline at end of file +InterfaceFreshness: Prüfungszeitraum (h) +ConfigInterfacesHeading: Konfiguration Warnung Schnittstellen + +IWTActAdd: Hinzufügen +IWTActDelete: Entfernen +InterfaceWarningAdded: Schnittstellenwarnungszeit hinzugefügt oder geändert +InterfaceWarningDeleted n@Int: #{pluralDEeN n "Schnittstellenwarnungszeit"} gelöscht \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index d8f6ca0d7..dff532fa9 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -149,4 +149,10 @@ InterfaceSubtype: Affecting InterfaceWrite: Write InterfaceSuccess: Returned InterfaceInfo: Message -InterfaceFreshness: Check hours \ No newline at end of file +InterfaceFreshness: Check hours +ConfigInterfacesHeading: Configuration interface warnings + +IWTActAdd: Add +IWTActDelete: Delete +InterfaceWarningAdded: Interface warning time added/changed +InterfaceWarningDeleted n: #{pluralENsN n "interface warning time"} deleted \ No newline at end of file diff --git a/routes b/routes index 1030745a2..98042a4a7 100644 --- a/routes +++ b/routes @@ -76,6 +76,7 @@ /admin/problems/r-without-f ProblemFbutNoR GET /admin/problems/avs ProblemAvsSynchR GET POST /admin/problems/avs/errors ProblemAvsErrorR GET +/admin/config/interfaces ConfigInterfacesR GET POST /comm CommCenterR GET /comm/email MailCenterR GET POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 6eebe6da3..6c33958e3 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -122,6 +122,7 @@ breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just AdminProblemsR breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just AdminProblemsR +breadcrumb ConfigInterfacesR = i18nCrumb MsgConfigInterfacesHeading $ Just AdminProblemsR breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR @@ -2533,6 +2534,20 @@ pageActions AdminCrontabR = return } ] +pageActions AdminProblemsR = return + [ NavPageActionPrimary + { navLink = defNavLink MsgConfigInterfacesHeading ConfigInterfacesR + , navChildren = [] + } + , NavPageActionPrimary + { navLink = defNavLink MsgProblemsAvsSynchHeading ProblemAvsSynchR + , navChildren = [] + } + , NavPageActionSecondary + { navLink = defNavLink MsgProblemsAvsErrorHeading ProblemAvsErrorR + } + ] + pageActions _ = return [] submissionList :: ( MonadIO m diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 00de8e004..de9a44b18 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -8,12 +8,14 @@ module Handler.Health.Interface getHealthInterfaceR , mkInterfaceLogTable , runInterfaceChecks + , getConfigInterfacesR, postConfigInterfacesR ) where import Import --- import qualified Data.Set as Set +import qualified Data.Set as Set +import qualified Data.Map as Map import qualified Data.Text as Text import Handler.Utils import Handler.Utils.Concurrent @@ -24,6 +26,8 @@ import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Legacy as EL (on) import qualified Database.Persist.Sql as E (deleteWhereCount) +defaultInterfaceWarnHours :: Int +defaultInterfaceWarnHours = 3 * 24 -- if no warn time can be found, use 3 days instead -- | identify a wildcard argument wc2null :: Text -> Maybe Text @@ -148,7 +152,7 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F" -- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- WORKS OKAY - let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead + let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours) -- if no default time is set, use a default instead return (ilog, ihour) queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog) @@ -258,3 +262,140 @@ avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" ( -- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime _ -> return () + + + +data IWTableAction + = IWTActAdd + | IWTActDelete + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe IWTableAction +instance Finite IWTableAction +nullaryPathPiece ''IWTableAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''IWTableAction id + +data IWTableActionData + = IWTActAddData + { iwtActInterface :: Text + , iwtActSubtype :: Maybe Text + , iwtActWrite :: Maybe Bool + , iwtActHours :: Int + } + | IWTActDeleteData + deriving (Eq, Ord, Read, Show, Generic) + +type IWTableExpr = E.SqlExpr (Entity InterfaceHealth) + +queryInterfaceHealth :: IWTableExpr -> E.SqlExpr (Entity InterfaceHealth) +queryInterfaceHealth = id + +type IWTableData = DBRow (Entity InterfaceHealth) + +resultInterfaceHealth :: Lens' IWTableData (Entity InterfaceHealth) +resultInterfaceHealth = _dbrOutput + +wildcardCell :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b +wildcardCell _ Nothing = textCell "*" +wildcardCell c (Just x) = c x + +mkInterfaceWarnTable :: DB (FormResult (IWTableActionData, Set InterfaceHealthId), Widget) +mkInterfaceWarnTable = do + let + mkOption :: E.Value Text -> Option Text + mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } + getSuggestion pj = E.select $ E.distinct $ do + il <- E.from $ E.table @InterfaceLog + let res = il E.^. pj + E.orderBy [E.asc res] + pure res + suggestionInterface :: HandlerFor UniWorX (OptionList Text) + suggestionInterface = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogInterface) + suggestionSubtype :: HandlerFor UniWorX (OptionList Text) + suggestionSubtype = mkOptionList . fmap mkOption <$> runDB (getSuggestion InterfaceLogSubtype) + dbtIdent = "interface-warnings" :: Text + dbtSQLQuery :: IWTableExpr -> E.SqlQuery IWTableExpr + dbtSQLQuery = return + dbtRowKey = queryInterfaceHealth >>> (E.^. InterfaceHealthId) + dbtProj = dbtProjId + dbtColonnade = formColonnade $ mconcat + [ dbSelect (applying _2) id (return . view (resultInterfaceHealth . _entityKey)) + , sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultInterfaceHealth . _entityVal . _interfaceHealthInterface) -> n) -> textCell n + , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ wildcardCell textCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthSubtype ) + , sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ wildcardCell (`ifIconCell` IconEdit) . view (resultInterfaceHealth . _entityVal . _interfaceHealthWrite ) + , sortable (Just "hours") (i18nCell MsgInterfaceFreshness ) $ numCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours ) + , sortable (Just "hours") (i18nCell MsgInterfaceFreshness ) $ textCell . formatDiffHours . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours) + ] + dbtSorting = mconcat + [ singletonMap "interface" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthInterface) + , singletonMap "subtype" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthSubtype) + , singletonMap "write" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthWrite) + , singletonMap "time" $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthHours) + ] + dbtFilter = mempty + dbtFilterUI = mempty + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = let acts :: Map IWTableAction (AForm Handler IWTableActionData) + acts = mconcat + [ singletonMap IWTActAdd $ IWTActAddData + <$> apreq (textField & cfStrip & addDatalist suggestionInterface) (fslI MsgInterfaceName) Nothing + <*> aopt (textField & cfStrip & addDatalist suggestionSubtype) (fslI MsgInterfaceSubtype) Nothing + <*> aopt boolField' (fslI MsgInterfaceWrite) Nothing + <*> apreq intField (fslI MsgInterfaceFreshness) Nothing + , singletonMap IWTActDelete $ pure IWTActDeleteData + ] + in renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + postprocess :: FormResult (First IWTableActionData, DBFormResult InterfaceHealthId Bool IWTableData) + -> FormResult ( IWTableActionData, Set InterfaceHealthId) + postprocess inp = do + (First (Just act), jobMap) <- inp + let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap + return (act, jobSet) + psValidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"] + over _1 postprocess <$> dbTable psValidator DBTable{..} + +getConfigInterfacesR, postConfigInterfacesR :: Handler Html +getConfigInterfacesR = postConfigInterfacesR +postConfigInterfacesR = do + + -- we abuse messageTooltip for colored icons here + msgSuccessTooltip <- messageI Success MsgMessageSuccess + -- msgWarningTooltip <- messageI Warning MsgMessageWarning + msgErrorTooltip <- messageI Error MsgMessageError + let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip + ((interfaceOks, interfaceTable), (warnRes, configTable)) <- runDB $ (,) + <$> mkInterfaceLogTable flagError mempty + <*> mkInterfaceWarnTable + let interfacesBadNr = length $ filter (not . snd) interfaceOks + formResult warnRes $ \case + (IWTActAddData{..}, _) -> do + void $ runDB $ upsertBy + (UniqueInterfaceHealth iwtActInterface iwtActSubtype iwtActWrite) + ( InterfaceHealth iwtActInterface iwtActSubtype iwtActWrite iwtActHours) + [InterfaceHealthHours =. iwtActHours] + addMessageI Success MsgInterfaceWarningAdded + reloadKeepGetParams ConfigInterfacesR + (IWTActDeleteData, ihids) -> do + runDB $ mapM_ delete ihids + addMessageI Success $ MsgInterfaceWarningDeleted $ Set.size ihids + reloadKeepGetParams ConfigInterfacesR + + siteLayoutMsg MsgConfigInterfacesHeading $ do + setTitleI MsgConfigInterfacesHeading + let defWarnTime = formatDiffHours defaultInterfaceWarnHours + $(i18nWidgetFile "config-interfaces") \ No newline at end of file diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 7ffbee74f..b470a288e 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -10,7 +10,8 @@ module Handler.Utils.DateTime , toTimeOfDay , toMidnight, beforeMidnight, toMidday, toMorning , toFullHour, roundDownToMinutes, addHours - , formatDiffDays, formatCalendarDiffDays + , formatDiffDays, formatDiffHours + , formatCalendarDiffDays , formatTime' , formatTime, formatTimeUser, formatTimeW, formatTimeMail , formatTimeRange, formatTimeRangeW, formatTimeRangeMail @@ -144,8 +145,8 @@ getDateTimeFormatUser sel mUser = do getDateTimeFormatUser' :: SelDateTimeFormat -> User -> DateTimeFormat getDateTimeFormatUser' SelFormatDateTime usr = usr & userDateTimeFormat -getDateTimeFormatUser' SelFormatDate usr = usr & userDateFormat -getDateTimeFormatUser' SelFormatTime usr = usr & userTimeFormat +getDateTimeFormatUser' SelFormatDate usr = usr & userDateFormat +getDateTimeFormatUser' SelFormatTime usr = usr & userTimeFormat getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter getDateTimeFormatter = do @@ -160,7 +161,7 @@ getDateTimeFormatterUser mUser = do return $ mkDateTimeFormatter locale formatMap appTZ getDateTimeFormatterUser' :: (MonadHandler m) => User -> m DateTimeFormatter -getDateTimeFormatterUser' usr = do +getDateTimeFormatterUser' usr = do locale <- getTimeLocale let formatMap = flip getDateTimeFormatUser' usr return $ mkDateTimeFormatter locale formatMap appTZ @@ -263,18 +264,21 @@ formatDiffDays t inHours = tshow $ convertBy nominalHour inMinutes = tshow $ convertBy nominalMinute +formatDiffHours :: Integral a => a -> Text +formatDiffHours = formatDiffDays . secondsToNominalDiffTime . (* 360) . fromIntegral + formatCalendarDiffDays :: CalendarDiffDays -> Text -formatCalendarDiffDays = pack . iso8601Show +formatCalendarDiffDays = pack . iso8601Show setYear :: Integer -> Day -> Day setYear year date = fromGregorian year m d where (_,m,d) = toGregorian date -getYear :: Day -> Integer +getYear :: Day -> Integer getYear date = y - where - (y,_,_) = toGregorian date + where + (y,_,_) = toGregorian date dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7 @@ -310,10 +314,10 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal -- CalendarDiffDays -- ---------------------- -fromMonths :: Integral a => a -> CalendarDiffDays +fromMonths :: Integral a => a -> CalendarDiffDays fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent -fromDays :: Integral a => a -> CalendarDiffDays +fromDays :: Integral a => a -> CalendarDiffDays fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d } addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime @@ -393,7 +397,7 @@ formatTimeRangeMail = formatTimeRange' formatTimeMail formatGregorianW :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Integer -> Int -> Int -> WidgetFor UniWorX () formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d -instance Csv.ToField ZonedTime where +instance Csv.ToField ZonedTime where toField = Csv.toField . iso8601Show -- also see Data.Time.Clock.Instances diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index fbf697fec..f44763c48 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -316,6 +316,7 @@ makeLenses_ ''AuthorshipStatementDefinition makeLenses_ ''PrintJob makeLenses_ ''InterfaceLog +makeLenses_ ''InterfaceHealth makeLenses_ ''AdminProblem makeLenses_ ''ProblemLog diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index 3909155cf..85701ef5a 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -1,6 +1,6 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# SPDX-FileCopyrightText: 2022-24 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later @@ -62,7 +62,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $else _{MsgInterfacesOk} ^{interfaceTable} - +

+ + _{MsgConfigInterfacesHeading}

_{MsgProblemsHeadingMisc} diff --git a/templates/i18n/config-interfaces/de-de-formal.hamlet b/templates/i18n/config-interfaces/de-de-formal.hamlet new file mode 100644 index 000000000..63265ad51 --- /dev/null +++ b/templates/i18n/config-interfaces/de-de-formal.hamlet @@ -0,0 +1,41 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
+

+ _{MsgMenuInterfaces} +
+

+ Eine Schnittstelle gilt als fehlgeschlagen, wenn die letzte Transaktion dieser Schnittstelle ein konkreten Fehler lieferte, + oder wenn seit einer gewissen Anzahl an Stunden kein erneuter Erfolg für diese Schnittstelle registriert wurde. + + Diese Zeitspanne beträgt normalerweise: #{defWarnTime} + + Mit der nachfolgend gezeigten Tabelle kann diese Zeitspanne zwischen letztem Erfolg und dem Anzeigen eines Fehlers aufgrund + des Ausbleibens eines erneuten Erfolges für einzelne Schnittstellen geändert werden. + Einträge mit unspezifiertem _{MsgInterfaceSubtype} und/oder _{MsgInterfaceWrite} betreffen alle drauf passenden Schnittstellen, + sofern es keine anderen passenden, besser spezifizierten Einträge gibt. + + Die Zeitspanne ist hier immer in Stunden anzugeben. + Eine negative Stundenzahl deaktiviert den Warnungsmechanismus für ausbleibende wiederholte Erfolge; + in diesem Fall werden für die Schnittstelle nur tatsächliche Fehlschläge als Fehler gemeldet. +

+ ^{configTable} + +

+

+ _{MsgMenuInterfaces} +
+

+ Current interface health is shown here for reference +

+ $if interfacesBadNr > 0 + _{MsgInterfacesFail interfacesBadNr} + $else + _{MsgInterfacesOk} + ^{interfaceTable} + + diff --git a/templates/i18n/config-interfaces/en-eu.hamlet b/templates/i18n/config-interfaces/en-eu.hamlet new file mode 100644 index 000000000..0b36757d5 --- /dev/null +++ b/templates/i18n/config-interfaces/en-eu.hamlet @@ -0,0 +1,36 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +

+

+ _{MsgMenuInterfaces} +
+

+ An interface is flagged as failed, if no success had been reported within the last #{defWarnTime} + + The following table allows to change the time span between the last success and before an error is raised. + A time value having _{MsgInterfaceSubtype} and/or _{MsgInterfaceWrite} left unspecified affects all matching interfeaces, + unless another more specified matching row exists for a particular interface. + + The time span is configure by a number of hours. + A negative hour value disables the raising of an error by time entirely; in this case, an error is only raised if the last interface transaction reported failure. +

+ ^{configTable} + +

+

+ _{MsgMenuInterfaces} +
+

+ Current interface health is shown here for reference +

+ $if interfacesBadNr > 0 + _{MsgInterfacesFail interfacesBadNr} + $else + _{MsgInterfacesOk} + ^{interfaceTable} + +