fix(health): negative interface routes working as intended now
This commit is contained in:
parent
618c78a69d
commit
3303c4eebf
@ -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,7 +60,7 @@ 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
|
||||
|
||||
@ -72,9 +70,9 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for bac
|
||||
let interfs = splitInterfaces $ identifyInterfaces ris
|
||||
(missing, allok, res, iltable) <- runInterfaceLogTable interfs
|
||||
when missing notFound -- send 404 if any requested interface was not found
|
||||
let ihstatus = if allok then status200
|
||||
let ihstatus = if allok then status200
|
||||
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]
|
||||
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
|
||||
@ -100,19 +98,12 @@ runInterfaceLogTable interfs@(reqIfs,_) = do
|
||||
allok = all snd res
|
||||
return (missing, allok, res, twgt)
|
||||
|
||||
ihDebugShow :: Unique InterfaceHealth -> Text
|
||||
ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")"
|
||||
|
||||
-- NOTE: Using (~~.) instead of ()=~.)
|
||||
-- | 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)
|
||||
-- (~~.) _ Nothing = E.true
|
||||
-- (~~.) a (Just b) = a E.==. E.val b
|
||||
-- ihDebugShow :: Unique InterfaceHealth -> Text
|
||||
-- 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
|
||||
$logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
|
||||
-- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
|
||||
void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
|
||||
now <- liftIO getCurrentTime
|
||||
dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
|
||||
@ -122,27 +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 ~~. (sanitize <$> subt)
|
||||
-- E.&&. ilog E.^. InterfaceLogWrite ~~. writ
|
||||
-- | (UniqueInterfaceHealth ifce subt writ) <- crits
|
||||
-- ]
|
||||
-- let matchUIH crits = E.or
|
||||
-- [ 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
|
||||
-- ]
|
||||
-- unless (null reqIfs) $ E.where_ $ matchUIH reqIfs
|
||||
-- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs
|
||||
E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- NOT OKAY ONLY Printer F SEE ISSUE #155
|
||||
-- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY
|
||||
let matchUIH crits = E.or
|
||||
[ 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)
|
||||
|
||||
@ -211,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
|
||||
@ -227,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
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user