diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index c43ffaed8..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,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| +
+ #{plainMsg} +
+ ^{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 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)