Merge branch 'fradrive/health-interfaces' into 'master'
refactor interface-health See merge request fradrive/fradrive!27
This commit is contained in:
commit
99c3383581
@ -2,8 +2,6 @@
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- !!! TODO REMOVE ME
|
||||
|
||||
|
||||
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
|
||||
matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool
|
||||
matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw
|
||||
where
|
||||
where
|
||||
eqOrNothing _ Nothing = True
|
||||
eqOrNothing a b = a == b
|
||||
|
||||
|
||||
getHealthInterfaceR :: [Text] -> Handler Html
|
||||
getHealthInterfaceR ris = do
|
||||
let (forced, ris') = case ris of
|
||||
("force":ris0) -> (True , ris0)
|
||||
_ -> (False, ris )
|
||||
interfs = splitInterfaces $ identifyInterfaces ris'
|
||||
getHealthInterfaceR :: [Text] -> Handler TypedContent
|
||||
getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force"
|
||||
let interfs = splitInterfaces $ identifyInterfaces ris
|
||||
(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
|
||||
unless (forced || allok) $ sendResponseStatus internalServerError500 badMsg
|
||||
content <- siteLayoutMsg MsgMenuHealthInterface $ do
|
||||
setTitleI MsgMenuHealthInterface
|
||||
[whamlet|
|
||||
$if allok
|
||||
Interfaces are healthy.
|
||||
$else
|
||||
#{badMsg}
|
||||
|
||||
^{iltable}
|
||||
|]
|
||||
sendResponseStatus (bool internalServerError500 status200 allok) content
|
||||
when missing notFound -- send 404 if any requested interface was not found
|
||||
let ihstatus = if allok then status200
|
||||
else internalServerError500
|
||||
plainMsg = if allok then "Interfaces are healthy."
|
||||
else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
|
||||
sendResponseStatus ihstatus <=< selectRep $ do -- most browsers send accept:text/html, thus text/plain can be default here
|
||||
provideRep . return . RepPlain $ toContent plainMsg -- /?_accept=text/plain
|
||||
provideRep . siteLayoutMsg MsgMenuHealthInterface $ do -- /?_accept=text/html
|
||||
setTitleI MsgMenuHealthInterface
|
||||
[whamlet|
|
||||
<div>
|
||||
#{plainMsg}
|
||||
<div>
|
||||
^{iltable}
|
||||
|]
|
||||
|
||||
|
||||
runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
|
||||
@ -103,7 +99,7 @@ runInterfaceLogTable interfs@(reqIfs,_) = do
|
||||
return (missing, allok, res, twgt)
|
||||
|
||||
-- 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 flagError interfs@(reqIfs, banIfs) = do
|
||||
@ -117,17 +113,30 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
|
||||
dbtProj = dbtProjId
|
||||
dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do
|
||||
EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface
|
||||
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
|
||||
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite )
|
||||
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
|
||||
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite )
|
||||
)
|
||||
let matchUIH crits = E.or
|
||||
[ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce)
|
||||
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val (sanitize <$> subt)
|
||||
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ
|
||||
| (UniqueInterfaceHealth ifce subt writ) <- crits
|
||||
]
|
||||
unless (null reqIfs) $ E.where_ $ matchUIH reqIfs
|
||||
unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs
|
||||
[ E.and $ 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
|
||||
]
|
||||
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
|
||||
return (ilog, ihour)
|
||||
|
||||
@ -196,14 +205,6 @@ maybeRunCheck (reqIfs,banIfs) uih act
|
||||
act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now
|
||||
| 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 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"
|
||||
else do
|
||||
oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True]
|
||||
if oks > 0
|
||||
if oks > 0
|
||||
then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed"
|
||||
else mkLog True Nothing mempty
|
||||
where
|
||||
where
|
||||
mkLog = logInterface' "Printer" "Acknowledge" True
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -125,7 +125,7 @@ migrateAlwaysSafe = do
|
||||
in sql
|
||||
-- unless (tableExists "interface_health") $ do
|
||||
-- [executeQQ|
|
||||
-- INSERT INTO "interface_health" (interface, subtype, write, hours)
|
||||
-- INSERT INTO "interface_health" ("interface", "subtype", "write", "hours")
|
||||
-- VALUES
|
||||
-- ('Printer', 'Acknowledge', True, 168)
|
||||
-- , ('AVS' , 'Synch' , True , 96)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user