fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(health): interface-health

Browse Source 
- send text/plain by default
- attempt to fix negative sub-filters for interface health
This commit is contained in:
Steffen Jost 2024-02-06 15:37:00 +00:00
parent 4a843fe30e
commit 2a0bca1230
2 changed files with 14 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/Handler/Health/Interface.hs
View File

@ -76,18 +76,16 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for bac
else internalServerError500 else internalServerError500
plainMsg = if allok then "Interfaces are healthy." plainMsg = if allok then "Interfaces are healthy."
else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
sendResponseStatus ihstatus <=< selectRep $ do sendResponseStatus ihstatus <=< selectRep $ do -- most browsers send accept:text/html, thus text/plain can be default here
provideRep . siteLayoutMsg MsgMenuHealthInterface $ do provideRep . return . RepPlain $ toContent plainMsg -- /?_accept=text/plain
provideRep . siteLayoutMsg MsgMenuHealthInterface $ do -- /?_accept=text/html
setTitleI MsgMenuHealthInterface setTitleI MsgMenuHealthInterface
[whamlet| [whamlet|
<div> <div>
#{plainMsg} #{plainMsg}
<div> <div>
^{iltable} ^{iltable}
|] |]
provideRep $ return $ RepPlain $ toContent plainMsg
runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
@ -105,6 +103,12 @@ runInterfaceLogTable interfs@(reqIfs,_) = do
-- ihDebugShow :: Unique InterfaceHealth -> Text -- ihDebugShow :: Unique InterfaceHealth -> Text
-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")" -- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")"
-- | like (=~.) but avoids condition entirely if second argument is Nothing; Note that using =~. with E.val Nothing did not work somehow!
infixl 4 ~~.
(~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool)
(~~.) a Nothing = E.true
(~~.) a (Just b) = a E.==. E.val b
mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
-- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
@ -122,8 +126,8 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
) )
let matchUIH crits = E.or let matchUIH crits = E.or
[ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce)
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val (sanitize <$> subt) E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt)
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ E.&&. ilog E.^. InterfaceLogWrite ~~. writ
| (UniqueInterfaceHealth ifce subt writ) <- crits | (UniqueInterfaceHealth ifce subt writ) <- crits
] ]
unless (null reqIfs) $ E.where_ $ matchUIH reqIfs unless (null reqIfs) $ E.where_ $ matchUIH reqIfs

4
src/Model/Migration/Definitions.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de> -- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -125,7 +125,7 @@ migrateAlwaysSafe = do
in sql in sql
-- unless (tableExists "interface_health") $ do -- unless (tableExists "interface_health") $ do
-- [executeQQ| -- [executeQQ|
-- INSERT INTO "interface_health" (interface, subtype, write, hours) -- INSERT INTO "interface_health" ("interface", "subtype", "write", "hours")
-- VALUES -- VALUES
-- ('Printer', 'Acknowledge', True, 168) -- ('Printer', 'Acknowledge', True, 168)
-- , ('AVS' , 'Synch' , True , 96) -- , ('AVS' , 'Synch' , True , 96)