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

Merge branch 'fradrive/health-interfaces' into 'master'

Browse Source 
refactor interface-health

See merge request fradrive/fradrive!27
This commit is contained in:
Steffen Jost 2024-02-08 07:59:38 +00:00
commit 99c3383581
2 changed files with 46 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,8 +2,6 @@
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- !!! TODO REMOVE ME
module Handler.Health.Interface module Handler.Health.Interface
( (
@ -62,32 +60,30 @@ splitInterfaces = foldl' aux mempty
-- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second -- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second
matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool
matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw
where where
eqOrNothing _ Nothing = True eqOrNothing _ Nothing = True
eqOrNothing a b = a == b eqOrNothing a b = a == b
getHealthInterfaceR :: [Text] -> Handler Html getHealthInterfaceR :: [Text] -> Handler TypedContent
getHealthInterfaceR ris = do getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force"
let (forced, ris') = case ris of let interfs = splitInterfaces $ identifyInterfaces ris
("force":ris0) -> (True , ris0)
_ -> (False, ris )
interfs = splitInterfaces $ identifyInterfaces ris'
(missing, allok, res, iltable) <- runInterfaceLogTable interfs (missing, allok, res, iltable) <- runInterfaceLogTable interfs
let badMsg = "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] when missing notFound -- send 404 if any requested interface was not found
when missing notFound -- send 404 if any requested interface was not found let ihstatus = if allok then status200
unless (forced || allok) $ sendResponseStatus internalServerError500 badMsg else internalServerError500
content <- siteLayoutMsg MsgMenuHealthInterface $ do plainMsg = if allok then "Interfaces are healthy."
setTitleI MsgMenuHealthInterface else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
[whamlet| sendResponseStatus ihstatus <=< selectRep $ do -- most browsers send accept:text/html, thus text/plain can be default here
$if allok provideRep . return . RepPlain $ toContent plainMsg -- /?_accept=text/plain
Interfaces are healthy. provideRep . siteLayoutMsg MsgMenuHealthInterface $ do -- /?_accept=text/html
$else setTitleI MsgMenuHealthInterface
#{badMsg} [whamlet|
<div>
^{iltable} #{plainMsg}
|] <div>
sendResponseStatus (bool internalServerError500 status200 allok) content ^{iltable}
|]
runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
@ -103,7 +99,7 @@ runInterfaceLogTable interfs@(reqIfs,_) = do
return (missing, allok, res, twgt) return (missing, allok, res, twgt)
-- 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 <> ")"
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
@ -117,17 +113,30 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
dbtProj = dbtProjId dbtProj = dbtProjId
dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do
EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite )
) )
let matchUIH crits = E.or let matchUIH crits = E.or
[ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) [ E.and $ catMaybes
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val (sanitize <$> subt) [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ , (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt
| (UniqueInterfaceHealth ifce subt writ) <- crits , (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ
] ]
unless (null reqIfs) $ E.where_ $ matchUIH reqIfs | (UniqueInterfaceHealth ifce subt writ) <- crits
unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs ]
matchUIHnot crits = E.and
[ E.or $ catMaybes
[ ilog E.^. InterfaceLogInterface E.!=. E.val (sanitize ifce) & Just
, (ilog E.^. InterfaceLogSubtype E.!=.) . E.val . sanitize <$> subt
, (ilog E.^. InterfaceLogWrite E.!=.) . E.val <$> writ
]
| (UniqueInterfaceHealth ifce subt writ) <- crits
]
unless (null reqIfs) $ E.where_ $ matchUIH reqIfs
unless (null banIfs) $ E.where_ $ matchUIHnot banIfs
-- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155
-- 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_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- 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 $ 3 * 24) -- if no default time is set, use 3 days instead
return (ilog, ihour) return (ilog, ihour)
@ -196,14 +205,6 @@ maybeRunCheck (reqIfs,banIfs) uih act
act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now
| otherwise = return () | otherwise = return ()
-- maybeRunCheck :: Unique InterfaceHealth -> (Int -> DB ()) -> DB ()
-- maybeRunCheck uih act = maybeM (return ()) (act . interfaceHealthHours . entityVal) $ getBy uih
-- maybeRunCheck uih act = getBy uih >>= flip whenIsJust (act . interfaceHealthHours . entityVal)
-- where
-- ih2hours :: Entity InterfaceHealth -> Int
-- -- ih2hours Entity{entityVal=InterfaceHealth{interfaceHealthHours=h}} = h
-- ih2hours = interfaceHealthHours . entityVal
lprAckCheck :: ReqBanInterfaceHealth -> DB () lprAckCheck :: ReqBanInterfaceHealth -> DB ()
lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do
@ -212,10 +213,10 @@ lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Ju
then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist" then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist"
else do else do
oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True] oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True]
if oks > 0 if oks > 0
then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed" then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed"
else mkLog True Nothing mempty else mkLog True Nothing mempty
where where
mkLog = logInterface' "Printer" "Acknowledge" True mkLog = logInterface' "Printer" "Acknowledge" True

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)