252 lines
13 KiB
Haskell
252 lines
13 KiB
Haskell
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
|
|
module Handler.Health.Interface
|
|
(
|
|
getHealthInterfaceR
|
|
, mkInterfaceLogTable
|
|
, runInterfaceChecks
|
|
)
|
|
where
|
|
|
|
import Import
|
|
|
|
-- import qualified Data.Set as Set
|
|
import qualified Data.Text as Text
|
|
import Handler.Utils
|
|
import Handler.Utils.Concurrent
|
|
|
|
-- import Database.Esqueleto.Experimental ((:&)(..))
|
|
import qualified Database.Esqueleto.Experimental as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import qualified Database.Esqueleto.Legacy as EL (on)
|
|
import qualified Database.Persist.Sql as E (deleteWhereCount)
|
|
|
|
|
|
-- | identify a wildcard argument
|
|
wc2null :: Text -> Maybe Text
|
|
-- wc2null "." = Nothing -- does not work, since dots are eliminated in URLs
|
|
-- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface
|
|
wc2null "_" = Nothing
|
|
wc2null "*" = Nothing
|
|
wc2null o = Just o
|
|
|
|
-- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool
|
|
pbool :: Text -> Maybe Bool
|
|
pbool (Text.toLower . Text.strip -> w)
|
|
| w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True
|
|
| w `elem` ["0", "f", "false","falsch"] = Just False
|
|
| otherwise = Nothing
|
|
|
|
-- | parse UniqueInterfaceHealth with subtype and write arguments being optional for the last interface. Wildcards '_' or '.' are also allowed in all places.
|
|
identifyInterfaces :: [Text] -> [Unique InterfaceHealth]
|
|
identifyInterfaces [] = []
|
|
identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing]
|
|
identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing]
|
|
identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r
|
|
|
|
type ReqBanInterfaceHealth = ([Unique InterfaceHealth],[Unique InterfaceHealth])
|
|
|
|
-- | Interface names prefixed with '-' are to be excluded from the query
|
|
splitInterfaces :: [Unique InterfaceHealth] -> ReqBanInterfaceHealth
|
|
splitInterfaces = foldl' aux mempty
|
|
where
|
|
aux (reqs,bans) uih@(UniqueInterfaceHealth i s w)
|
|
| Just ('-', b) <- Text.uncons i = (reqs, UniqueInterfaceHealth b s w : bans)
|
|
| otherwise = (uih : reqs, bans)
|
|
|
|
-- | 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
|
|
eqOrNothing _ Nothing = True
|
|
eqOrNothing a b = a == b
|
|
|
|
|
|
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
|
|
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)
|
|
runInterfaceLogTable interfs@(reqIfs,_) = do
|
|
-- we abuse messageTooltip for colored icons here
|
|
msgSuccessTooltip <- messageI Success MsgMessageSuccess
|
|
-- msgWarningTooltip <- messageI Warning MsgMessageWarning
|
|
msgErrorTooltip <- messageI Error MsgMessageError
|
|
let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
|
|
(res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
|
|
let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
|
|
allok = all snd res
|
|
return (missing, allok, res, twgt)
|
|
|
|
-- 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])
|
|
void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
|
|
now <- liftIO getCurrentTime
|
|
dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
|
|
where
|
|
sanitize = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü']
|
|
dbtIdent = "interface-log" :: Text
|
|
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 )
|
|
)
|
|
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
|
|
-- unless (null banIfs) $ E.where_ $ E.not_ $ E.parens $ matchUIH banIfs -- WORKS OKAY
|
|
-- 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_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY
|
|
-- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- WORKS 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)
|
|
|
|
queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog)
|
|
queryILog = $(E.sqlLOJproj 2 1)
|
|
resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog
|
|
resultILog = _dbrOutput . _1 . _entityVal
|
|
resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int
|
|
resultHours = _dbrOutput . _2 . E._unValue
|
|
|
|
dbtRowKey = queryILog >>> (E.^.InterfaceLogId)
|
|
colonnade now = mconcat
|
|
[ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do
|
|
let hours = row ^. resultHours
|
|
-- defmsg = row ^? resultErrMsg
|
|
logtime = row ^. resultILog . _interfaceLogTime
|
|
success = row ^. resultILog . _interfaceLogSuccess
|
|
iface = row ^. resultILog . _interfaceLogInterface
|
|
status = success && (hours < 0 || now <= addHours hours logtime)
|
|
in tellCell [(iface,status)] $
|
|
wgtCell $ flagError status
|
|
, sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
|
|
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype)
|
|
, sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
|
|
, sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
|
|
, sortable Nothing (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
|
|
, sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
|
|
, sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s
|
|
, sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of
|
|
InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt $ bool i "AVS-Log" $ null i
|
|
InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i
|
|
InterfaceLog _ _ _ _ _ i _ -> textCell i
|
|
]
|
|
|
|
dbtSorting = mconcat
|
|
[ singletonMap "interface" $ SortColumn $ queryILog >>> (E.^. InterfaceLogInterface)
|
|
, singletonMap "subtype" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSubtype)
|
|
, singletonMap "write" $ SortColumn $ queryILog >>> (E.^. InterfaceLogWrite)
|
|
, singletonMap "time" $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime)
|
|
, singletonMap "rows" $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows)
|
|
, singletonMap "success" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess)
|
|
]
|
|
ilvalidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
|
|
dbtFilter = mempty
|
|
dbtFilterUI = mempty
|
|
dbtStyle = def
|
|
dbtParams = def
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
|
|
-- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call
|
|
runInterfaceChecks :: ReqBanInterfaceHealth -> DB ()
|
|
runInterfaceChecks interfs = do
|
|
avsInterfaceCheck interfs
|
|
lprAckCheck interfs
|
|
|
|
maybeRunCheck :: ReqBanInterfaceHealth -> Unique InterfaceHealth -> (UTCTime -> DB ()) -> DB ()
|
|
maybeRunCheck (reqIfs,banIfs) uih act
|
|
| null reqIfs || any (matchesUniqueInterfaceHealth uih) reqIfs
|
|
, null banIfs || not (any (matchesUniqueInterfaceHealth uih) banIfs) = do
|
|
mih <- getBy uih
|
|
whenIsJust mih $ \eih -> do
|
|
now <- liftIO getCurrentTime
|
|
act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now
|
|
| otherwise = return ()
|
|
|
|
|
|
lprAckCheck :: ReqBanInterfaceHealth -> DB ()
|
|
lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do
|
|
unproc <- selectList [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. False] []
|
|
if notNull unproc
|
|
then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist"
|
|
else do
|
|
oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True]
|
|
if oks > 0
|
|
then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed"
|
|
else mkLog True Nothing mempty
|
|
where
|
|
mkLog = logInterface' "Printer" "Acknowledge" True
|
|
|
|
|
|
avsInterfaceCheck :: ReqBanInterfaceHealth -> DB ()
|
|
avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \cutOffOldTime -> do
|
|
avsSynchStats <- E.select $ do
|
|
uavs <- E.from $ E.table @UserAvs
|
|
E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime
|
|
let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError)
|
|
E.groupBy isOk
|
|
E.orderBy [E.descNullsLast isOk]
|
|
return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch)
|
|
let
|
|
mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do
|
|
fmtCut <- formatTime SelFormatDate cutOffOldTime
|
|
fmtBad <- formatTime SelFormatDateTime badTime
|
|
return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad
|
|
mkBadInfo _ _ = return mempty
|
|
writeAvsSynchStats okRows badInfo =
|
|
logInterface' "AVS" "Synch" True (null badInfo) okRows badInfo
|
|
--case $(unValueN 3) <$> avsSynchStats of
|
|
case avsSynchStats of
|
|
((E.Value True , E.Value okRows, E.Value _okTime):(E.Value False, E.Value badRows, E.Value badTime):_) ->
|
|
writeAvsSynchStats (Just okRows) =<< mkBadInfo badRows badTime
|
|
((E.Value True , E.Value okRows, E.Value _okTime):_) ->
|
|
writeAvsSynchStats (Just okRows) mempty
|
|
((E.Value False, E.Value badRows, E.Value badTime):_) ->
|
|
-- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
|
|
writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime
|
|
_ -> return ()
|