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

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

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

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

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

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

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

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' SelFormatDate     usr = usr & userDateFormat
-getDateTimeFormatUser' SelFormatTime     usr = usr & userTimeFormat   
+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 
+  where
-    (y,_,_) = toGregorian date    
+    (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

src/Utils/Lens.hs

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

templates/admin-problems.hamlet

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

templates/i18n/config-interfaces/de-de-formal.hamlet

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

templates/i18n/config-interfaces/en-eu.hamlet

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