chore(health): fix #154 by adding interface warning threshold edit handler

This commit is contained in:
Steffen Jost 2024-08-21 17:34:19 +02:00
parent f61c35cfe7
commit 407ba543a1
10 changed files with 270 additions and 17 deletions

View File

@ -149,4 +149,10 @@ InterfaceSubtype: Betreffend
InterfaceWrite: Schreibend
InterfaceSuccess: Rückmeldung
InterfaceInfo: Nachricht
InterfaceFreshness: Prüfungszeitraum (h)
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

View File

@ -149,4 +149,10 @@ InterfaceSubtype: Affecting
InterfaceWrite: Write
InterfaceSuccess: Returned
InterfaceInfo: Message
InterfaceFreshness: Check hours
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

1
routes
View File

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

View File

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

View File

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

View File

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

View File

@ -316,6 +316,7 @@ makeLenses_ ''AuthorshipStatementDefinition
makeLenses_ ''PrintJob
makeLenses_ ''InterfaceLog
makeLenses_ ''InterfaceHealth
makeLenses_ ''AdminProblem
makeLenses_ ''ProblemLog

View File

@ -1,6 +1,6 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$# SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
@ -62,7 +62,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$else
_{MsgInterfacesOk}
^{interfaceTable}
<p>
<a href=@{ConfigInterfacesR}>
_{MsgConfigInterfacesHeading}
<section>
<h2>
_{MsgProblemsHeadingMisc}

View File

@ -0,0 +1,41 @@
$newline never
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<h2>
_{MsgMenuInterfaces}
<div>
<p>
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.
<p>
^{configTable}
<section>
<h2>
_{MsgMenuInterfaces}
<div>
<p>
Current interface health is shown here for reference
<p>
$if interfacesBadNr > 0
_{MsgInterfacesFail interfacesBadNr}
$else
_{MsgInterfacesOk}
^{interfaceTable}

View File

@ -0,0 +1,36 @@
$newline never
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<h2>
_{MsgMenuInterfaces}
<div>
<p>
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.
<p>
^{configTable}
<section>
<h2>
_{MsgMenuInterfaces}
<div>
<p>
Current interface health is shown here for reference
<p>
$if interfacesBadNr > 0
_{MsgInterfacesFail interfacesBadNr}
$else
_{MsgInterfacesOk}
^{interfaceTable}