Merge branch 'fradrive/jost' into 'master'

chore(health): augement #154 by adding option to disable interface warnings

See merge request fradrive/fradrive!39

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

@@ -149,10 +149,13 @@ InterfaceSubtype: Betreffend
 InterfaceWrite: Schreibend
 InterfaceSuccess: Rückmeldung
 InterfaceInfo: Nachricht
-InterfaceFreshness: Prüfungszeitraum (h)
+InterfaceFreshness: Maximale Zugriffsfrist
-ConfigInterfacesHeading: Konfiguration Warnung Schnittstellen
+InterfaceFreshnessTooltip: Zeitspanne innerhalb der ein erneuter erfolgreicher Schnittstellenzugriff erfolgen muss, ohne Warnungen auszulösen
+ConfigInterfacesHeading: Konfiguration Zugriffsfristen
 
-IWTActAdd: Hinzufügen
+IWTActAdd: Hinzufügen/Ändern
 IWTActDelete: Entfernen
 InterfaceWarningAdded: Schnittstellenwarnungszeit hinzugefügt oder geändert
-InterfaceWarningDeleted n@Int: #{pluralDEeN n "Schnittstellenwarnungszeit"} gelöscht
+InterfaceWarningDeleted n@Int: #{pluralDEeN n "Schnittstellenwarnungszeit"} gelöscht
+InterfaceWarningDisabledEntirely: Alle Fehler ignorieren
+InterfaceWarningDisabledInterval: Keine Zugriffsfrist

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

@@ -149,10 +149,13 @@ InterfaceSubtype: Affecting
 InterfaceWrite: Write
 InterfaceSuccess: Returned
 InterfaceInfo: Message
-InterfaceFreshness: Check hours
+InterfaceFreshness: Maximum usage period
-ConfigInterfacesHeading: Configuration interface warnings
+InterfaceFreshnessTooltip: Time period within which the next successful interface access must occur to avoid a warning
+ConfigInterfacesHeading: Configure interface usage warnings
 
-IWTActAdd: Add
+IWTActAdd: Add/Edit
 IWTActDelete: Delete
 InterfaceWarningAdded: Interface warning time added/changed
-InterfaceWarningDeleted n: #{pluralENsN n "interface warning time"} deleted
+InterfaceWarningDeleted n: #{pluralENsN n "interface warning time"} deleted
+InterfaceWarningDisabledEntirely: Ignore all errors
+InterfaceWarningDisabledInterval: No maximum usage period

messages/uniworx/misc/de-de-formal.msg

@@ -12,6 +12,7 @@ FieldSecondary: Nebenfach
 MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich
 MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick
 WeekDay: Wochentag
+Hours: Stunden
 LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse
 Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"}
 Days num@Int64: #{num} #{pluralDE num "Tag" "Tage"}

messages/uniworx/misc/en-eu.msg

@@ -12,6 +12,7 @@ FieldSecondary: Minor
 MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated)
 MultiSelectTip: Multiple selection and desection via Ctrl-Click
 WeekDay: Day of the week
+Hours: Hours
 LdapIdentificationOrEmail: Fraport AG-Kennung / email address
 Months num: #{num} #{pluralEN num "Month" "Months"}
 Days num: #{num} #{pluralEN num "Day" "Days"}

src/Handler/Admin.hs

@@ -86,7 +86,7 @@ handleAdminProblems mbProblemTable = do
       <*> allRDriversHaveFs now
       <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime])
       <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
-      <*> mkInterfaceLogTable flagError mempty
+      <*> mkInterfaceLogTable mempty
   let interfacesBadNr = length $ filter (not . snd) interfaceOks
       -- interfacesOk = all snd interfaceOks
 

src/Handler/Health/Interface.hs

@@ -37,6 +37,12 @@ wc2null "_" = Nothing
 wc2null "*" = Nothing
 wc2null  o  = Just o
 
+warnIntervalCell :: (IsDBTable m b, Integral a) => a -> DBCell m b
+warnIntervalCell x
+  | x >= 0      = textCell $ formatDiffHours x
+  | x <= (-100) = i18nCell MsgInterfaceWarningDisabledEntirely
+  | otherwise   = i18nCell MsgInterfaceWarningDisabledInterval
+
 -- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool
 pbool :: Text -> Maybe Bool
 pbool (Text.toLower . Text.strip -> w)
@@ -92,12 +98,7 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do               -- for bac
 
 runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
 runInterfaceLogTable interfs@(reqIfs,_) = do
-  -- we abuse messageTooltip for colored icons here
+  (res, twgt) <- runDB $ mkInterfaceLogTable interfs
-  msgSuccessTooltip <- messageI Success MsgMessageSuccess
-  -- msgWarningTooltip <- messageI Warning MsgMessageWarning
-  msgErrorTooltip   <- messageI Error   MsgMessageError
-  let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
-  (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
   let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
       allok   = all snd res
   return (missing, allok, res, twgt)
@@ -105,12 +106,14 @@ runInterfaceLogTable interfs@(reqIfs,_) = do
 -- ihDebugShow :: Unique InterfaceHealth -> Text
 -- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")"
 
-mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
+mkInterfaceLogTable :: ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
-mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
+mkInterfaceLogTable interfs@(reqIfs, banIfs) = do
     --   $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
-    void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
+    flagError <- liftHandler $ do
+      void $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs -- ensure interface checkc are up to date
+      mkErrorFlag
     now <- liftIO getCurrentTime
-    dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
+    dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now flagError, ..}
   where
     sanitize      = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü']
     dbtIdent      = "interface-log" :: Text
@@ -157,27 +160,29 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
 
     queryILog     :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog)
     queryILog     = $(E.sqlLOJproj 2 1)
+    queryHealth   :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Maybe (Entity InterfaceHealth))
+    queryHealth   = $(E.sqlLOJproj 2 2)
     resultILog    :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog
     resultILog    = _dbrOutput . _1 . _entityVal
     resultHours   :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int
     resultHours   = _dbrOutput . _2 . E._unValue
 
     dbtRowKey     = queryILog >>> (E.^.InterfaceLogId)
-    colonnade now = mconcat
+    colonnade now flagError = mconcat
         [ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do
             let hours   = row ^. resultHours
                 -- defmsg  = row ^? resultErrMsg
                 logtime = row ^. resultILog . _interfaceLogTime
                 success = row ^. resultILog . _interfaceLogSuccess
                 iface   = row ^. resultILog . _interfaceLogInterface
-                status  = success && (hours < 0 || now <= addHours hours logtime)
+                status  = (success || hours <= -100) && (hours < 0 || now <= addHours hours logtime)
-            in tellCell [(iface,status)] $
+            in tellCell [(iface,status)] $ wgtCell $ flagError $ toMaybe (success || not status) status
-                wgtCell $ flagError status
         , sortable (Just "interface") (i18nCell MsgInterfaceName      ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
         , sortable (Just "subtype")   (i18nCell MsgInterfaceSubtype   ) $ textCell . view (resultILog . _interfaceLogSubtype)
         , sortable (Just "write")     (i18nCell MsgInterfaceWrite     ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
         , sortable (Just "time")      (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
-        , sortable Nothing            (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
+        , sortable (Just "hours")     (i18nCell MsgInterfaceFreshness & cellTooltips [SomeMessage MsgInterfaceFreshnessTooltip, SomeMessage MsgTableDiffDaysTooltip]
+                                                                      ) $ warnIntervalCell . view resultHours
         , sortable (Just "rows")      (i18nCell MsgTableRows          ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
         , sortable (Just "success")   (i18nCell MsgInterfaceSuccess   ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s
         , sortable Nothing            (i18nCell MsgInterfaceInfo      ) $ \(view resultILog -> ilt) -> case ilt of
@@ -193,6 +198,7 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
         , singletonMap "time"      $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime)
         , singletonMap "rows"      $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows)
         , singletonMap "success"   $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess)
+        , singletonMap "hours"     $ SortColumn $ \r -> E.coalesceDefault [queryHealth r E.?. InterfaceHealthHours] (E.val defaultInterfaceWarnHours)
         ]
     ilvalidator   = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
     dbtFilter     = mempty
@@ -296,7 +302,7 @@ resultInterfaceHealth :: Lens' IWTableData (Entity InterfaceHealth)
 resultInterfaceHealth = _dbrOutput
 
 wildcardCell :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b
-wildcardCell _ Nothing  = textCell "*"
+wildcardCell _ Nothing  = iconFixedCell $ icon IconWildcard
 wildcardCell c (Just x) = c x
 
 mkInterfaceWarnTable :: DB (FormResult (IWTableActionData, Set InterfaceHealthId), Widget)
@@ -321,16 +327,17 @@ mkInterfaceWarnTable = do
     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 "subtype")   (i18nCell MsgInterfaceSubtype   ) $ wildcardCell textCell . view (resultInterfaceHealth . _entityVal . _interfaceHealthSubtype )
-      , sortable (Just "write")     (i18nCell MsgInterfaceWrite     ) $ wildcardCell (`ifIconCell` IconEdit)  . view (resultInterfaceHealth . _entityVal . _interfaceHealthWrite   )
+      , sortable (Just "write")     (i18nCell MsgInterfaceWrite     ) $ wildcardCell (iconFixedCell . iconWriteReadOnly) . view (resultInterfaceHealth . _entityVal . _interfaceHealthWrite   )
-      , sortable (Just "hours")     (i18nCell MsgInterfaceFreshness ) $ numCell                               . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours   )
+      -- , sortable (Just "hours")     (i18nCell MsgInterfaceFreshness ) $ numCell                               . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours   )
-      , sortable (Just "hours")     (i18nCell MsgInterfaceFreshness ) $ textCell . formatDiffHours . view (resultInterfaceHealth . _entityVal . _interfaceHealthHours)
+      , sortable (Just "hours")     (i18nCell MsgInterfaceFreshness
+                              & cellTooltip MsgTableDiffDaysTooltip ) $ warnIntervalCell . 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)
+      , singletonMap "hours"     $ SortColumn $ queryInterfaceHealth >>> (E.^. InterfaceHealthHours)
       ]
     dbtFilter     = mempty
     dbtFilterUI   = mempty
@@ -347,7 +354,7 @@ mkInterfaceWarnTable = do
                       <$> 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
+                      <*> apreq  intField                                               (fslI MsgInterfaceFreshness & setTooltip MsgHours)  Nothing
                   , singletonMap IWTActDelete $ pure IWTActDeleteData
                   ]
              in renderAForm FormStandard
@@ -372,14 +379,8 @@ mkInterfaceWarnTable = do
 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
+    <$> mkInterfaceLogTable mempty
     <*> mkInterfaceWarnTable
   let interfacesBadNr = length $ filter (not . snd) interfaceOks
   formResult warnRes $ \case

src/Handler/Utils/DateTime.hs

@@ -265,7 +265,7 @@ formatDiffDays t
     inMinutes = tshow $ convertBy nominalMinute
 
 formatDiffHours :: Integral a => a -> Text
-formatDiffHours = formatDiffDays . secondsToNominalDiffTime . (* 360) . fromIntegral
+formatDiffHours = pack . iso8601Show . calendarTimeTime . secondsToNominalDiffTime . (* 3600) . fromIntegral
 
 formatCalendarDiffDays :: CalendarDiffDays -> Text
 formatCalendarDiffDays = pack . iso8601Show

src/Handler/Utils/Widgets.hs

@@ -173,6 +173,23 @@ companyWidget isPrimary (csh, cname, isSupervisor)
       | otherwise    = text2markup  corg
 
 
+---------------------
+-- Status Tooltips --
+---------------------
+
+-- | generate a generic colored icon to display success or failure to user
+mkErrorFlag :: Handler (Maybe Bool -> Widget)
+mkErrorFlag = do
+  -- we abuse messageTooltip for colored icons here
+  msgSuccessTooltip <- messageI Success MsgMessageSuccess
+  msgWarningTooltip <- messageI Warning MsgMessageWarning
+  msgErrorTooltip   <- messageI Error   MsgMessageError
+  let flagError Nothing       = messageTooltip msgWarningTooltip
+      flagError (Just False)  = messageTooltip msgErrorTooltip
+      flagError (Just True)   = messageTooltip msgSuccessTooltip
+  return flagError
+
+
 ----------
 -- HEAT --
 ----------

src/Utils/Icon.hs

@@ -122,7 +122,7 @@ data Icon
   --  IconMagic           -- indicates automatic updates
   | IconReroute           -- for notification rerouting
   | IconTop               -- indicating highest number/quantity/priority for something
-
+  | IconWildcard
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
   deriving anyclass (Universe, Finite, NFData)
 
@@ -222,6 +222,7 @@ iconText = \case
     -- IconMagic                   -> "wand-magic"
     IconReroute                 -> "directions"
     IconTop                     -> "arrow-to-top"
+    IconWildcard                -> "asterisk"
 nullaryPathPiece ''Icon $ camelToPathPiece' 1
 deriveLift ''Icon
 
@@ -331,6 +332,10 @@ iconQualificationBlock :: Bool -> Markup
 iconQualificationBlock True   = icon IconCertificate
 iconQualificationBlock False  = icon IconBlocked
 
+iconWriteReadOnly :: Bool -> Markup
+iconWriteReadOnly True  = icon IconEdit
+iconWriteReadOnly False = icon IconVisible
+
 ----------------
 -- For documentation on how to avoid these unneccessary functions
 -- we implement them here just once for the first icon:

src/Utils/Message.hs

@@ -228,3 +228,5 @@ messageTooltip Message{..} = let urgency = statusToUrgencyClass messageStatus
                                  tooltip = toWidget messageContent :: WidgetFor site ()
                                  isInlineTooltip = False
                              in $(whamletFile "templates/widgets/tooltip.hamlet")
+
+-- also see Handler.Utils.Widgets.mkErrorFlag for generic error icon tooltips

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

@@ -6,22 +6,23 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
   <h2>
-    _{MsgMenuInterfaces}
+    _{MsgConfigInterfacesHeading}
   <div>
     <p>
-      Eine Schnittstelle gilt als fehlgeschlagen, wenn die letzte Transaktion dieser Schnittstelle ein konkreten Fehler lieferte,
+      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.
+      oder wenn seit einer gewissen Zugriffsfrist kein erneuter Erfolg für diese Schnittstelle registriert wurde. #
-      
+    <p>
-      Diese Zeitspanne beträgt normalerweise: #{defWarnTime}
+      Diese Zeitspanne beträgt normalerweise: #{defWarnTime} #
-
+    <p>
-      Mit der nachfolgend gezeigten Tabelle kann diese Zeitspanne zwischen letztem Erfolg und dem Anzeigen eines Fehlers aufgrund 
+      Mit der nachfolgend gezeigten Tabelle kann diese Zugriffsfrist zwischen letztem Erfolg und dem Anzeigen eines Fehlers aufgrund #
-      des Ausbleibens eines erneuten Erfolges für einzelne Schnittstellen geändert werden. 
+      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, 
+      Einträge mit unspezifiertem _{MsgInterfaceSubtype} und/oder _{MsgInterfaceWrite} betreffen alle drauf passenden Schnittstellen, #
-      sofern es keine anderen passenden, besser spezifizierten Einträge gibt.
+      sofern es keine anderen passenden, besser spezifizierten Einträge gibt. #
-
+    <p>
-      Die Zeitspanne ist hier immer in Stunden anzugeben.
+      Die Zeitspanne ist hier immer in Stunden anzugeben. #
-      Eine negative Stundenzahl deaktiviert den Warnungsmechanismus für ausbleibende wiederholte Erfolge; 
+      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.
+      in diesem Fall werden für die Schnittstelle nur tatsächliche Fehlschläge als Fehler gemeldet. #
+      Eine negative Zeitspanne von -100 oder weniger deaktiviert alle Warnungen für diese Schnittstelle.
     <p>
       ^{configTable}
 

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

@@ -6,17 +6,19 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
   <h2>
-    _{MsgMenuInterfaces}
+    _{MsgConfigInterfacesHeading}
   <div>
     <p>
-      An interface is flagged as failed, if no success had been reported within the last #{defWarnTime}
+      An interface is flagged as failed, if an error is reported or if no new success had been reported within 
-
+      its maximum usage period, usually #{defWarnTime} #
-      The following table allows to change the time span between the last success and before an error is raised. 
+    <p>
-      A time value having _{MsgInterfaceSubtype} and/or _{MsgInterfaceWrite} left unspecified affects all matching interfeaces, 
+      The following table allows to change the time span between the last success and before an error is raised. #
-      unless another more specified matching row exists for a particular interface.
+      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. 
+    <p>
-      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.
+      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. #
+      A negative value of less than -100 disables all warnings for this interface.
     <p>
       ^{configTable}