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