From 42f1a802b52007ccca9595d732fc20f40cc66f6a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 10:32:00 +0000 Subject: [PATCH 1/6] chore(health): getHealthInterfaceR responds to mime content type header --- src/Handler/Health/Interface.hs | 39 ++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index c43ffaed8..1b6ee1dee 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -67,27 +67,30 @@ matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHe 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} + let respond = sendResponseStatus (bool internalServerError500 status200 allok) + plainMsg = if allok + then "Interfaces are healthy" + else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + selectRep $ do + provideRep $ do + content <- siteLayoutMsg MsgMenuHealthInterface $ do + setTitleI MsgMenuHealthInterface + [whamlet| +
+ #{plainMsg} +
+ ^{iltable} + |] + respond content + + provideRep $ do + respond $ RepPlain $ toContent plainMsg - ^{iltable} - |] - sendResponseStatus (bool internalServerError500 status200 allok) content runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) From 4a843fe30e35f346ffbe5c0337d69bf319cfeced Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 10:48:54 +0000 Subject: [PATCH 2/6] refactor(health): simplfy code following HealthR handler --- src/Handler/Health/Interface.hs | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 1b6ee1dee..87be63b89 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -68,28 +68,25 @@ matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHe getHealthInterfaceR :: [Text] -> Handler TypedContent -getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force" +getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force" let interfs = splitInterfaces $ identifyInterfaces ris (missing, allok, res, iltable) <- runInterfaceLogTable interfs - when missing notFound -- send 404 if any requested interface was not found - let respond = sendResponseStatus (bool internalServerError500 status200 allok) - plainMsg = if allok - then "Interfaces are healthy" - else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] - selectRep $ do - provideRep $ do - content <- siteLayoutMsg MsgMenuHealthInterface $ do + 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 + provideRep . siteLayoutMsg MsgMenuHealthInterface $ do setTitleI MsgMenuHealthInterface [whamlet|
#{plainMsg}
^{iltable} - |] - respond content + |] - provideRep $ do - respond $ RepPlain $ toContent plainMsg + provideRep $ return $ RepPlain $ toContent plainMsg From 2a0bca1230b456eb413842b37f03342b25e49742 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 15:37:00 +0000 Subject: [PATCH 3/6] refactor(health): interface-health - send text/plain by default - attempt to fix negative sub-filters for interface health --- src/Handler/Health/Interface.hs | 20 ++++++++++++-------- src/Model/Migration/Definitions.hs | 4 ++-- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 87be63b89..4e551eb96 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -76,18 +76,16 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for bac else internalServerError500 plainMsg = if allok then "Interfaces are healthy." else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] - sendResponseStatus ihstatus <=< selectRep $ do - provideRep . siteLayoutMsg MsgMenuHealthInterface $ do + 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|
#{plainMsg}
^{iltable} - |] - - provideRep $ return $ RepPlain $ toContent plainMsg - + |] runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) @@ -105,6 +103,12 @@ runInterfaceLogTable interfs@(reqIfs,_) = do -- ihDebugShow :: Unique InterfaceHealth -> Text -- 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 flagError interfs@(reqIfs, banIfs) = do -- $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 [ 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 + E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) + E.&&. ilog E.^. InterfaceLogWrite ~~. writ | (UniqueInterfaceHealth ifce subt writ) <- crits ] unless (null reqIfs) $ E.where_ $ matchUIH reqIfs diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index a875b9648..e7d34e713 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- 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) From 67552a666e2588c1f477eacd5036c09903b2d40e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 15:47:17 +0000 Subject: [PATCH 4/6] refactor(health): optimize sql query, needs tests --- src/Handler/Health/Interface.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 4e551eb96..e1a523dea 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -130,6 +130,14 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do E.&&. ilog E.^. InterfaceLogWrite ~~. writ | (UniqueInterfaceHealth ifce subt writ) <- crits ] + -- let matchUIH crits = E.or + -- [ E.and $ catMaybes + -- [ Just $ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) + -- , foldMap ((ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize) subt + -- , foldMap ((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 let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead From 618c78a69d7db77a745282c63356a936facff70d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 10:23:51 +0100 Subject: [PATCH 5/6] chore(health): examining cause of #155 --- src/Handler/Health/Interface.hs | 39 ++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index e1a523dea..42ec567fd 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -100,18 +100,19 @@ 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 <> ")" +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) -(~~.) a Nothing = E.true -(~~.) a (Just b) = a E.==. E.val b +-- 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 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, ..} @@ -124,22 +125,24 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do 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 + -- [ 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 - -- [ Just $ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - -- , foldMap ((ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize) subt - -- , foldMap ((ilog E.^. InterfaceLogWrite E.==.) . E.val ) writ + -- [ 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 + -- 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 ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) From 3303c4eebf928e527d2f9c1eb6e2495c10b94b13 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 10:39:21 +0100 Subject: [PATCH 6/6] fix(health): negative interface routes working as intended now --- src/Handler/Health/Interface.hs | 76 ++++++++++++++------------------- 1 file changed, 31 insertions(+), 45 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 42ec567fd..f64ef254f 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -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