fix(health): fix #151 by offering route /health/interface/*
This commit is contained in:
parent
bbb9f9fadb
commit
c71814d1ef
@ -121,10 +121,13 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen
|
||||
ProblemsAvsErrorHeading: Fehlermeldungen
|
||||
ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit
|
||||
|
||||
InterfacesOk: Schnittstellen sind ok.
|
||||
InterfacesFail n@Int: #{tshow n} Schnittstellenprobleme!
|
||||
InterfaceStatus !ident-ok: Status
|
||||
InterfaceName: Schnittstelle
|
||||
InterfaceLastSynch: Zuletzt
|
||||
InterfaceSubtype: Betreffend
|
||||
InterfaceWrite: Schreibend
|
||||
InterfaceSuccess: Rückmeldung
|
||||
InterfaceInfo: Nachricht
|
||||
InterfaceInfo: Nachricht
|
||||
InterfaceFreshness: Prüfungszeitraum (h)
|
||||
@ -121,10 +121,13 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences
|
||||
ProblemsAvsErrorHeading: Error Log
|
||||
ProblemsInterfaceSince: Only considering successes and errors since
|
||||
|
||||
InterfacesOk: Interfaces are ok.
|
||||
InterfacesFail n: #{tshow n} Interface problems!
|
||||
InterfaceStatus: Status
|
||||
InterfaceName: Interface
|
||||
InterfaceLastSynch: Last
|
||||
InterfaceSubtype: Affecting
|
||||
InterfaceWrite: Write
|
||||
InterfaceSuccess: Returned
|
||||
InterfaceInfo: Message
|
||||
InterfaceInfo: Message
|
||||
InterfaceFreshness: Check hours
|
||||
@ -26,7 +26,6 @@ InterfaceHealth
|
||||
interface Text
|
||||
subtype Text Maybe
|
||||
write Bool Maybe
|
||||
hours Int
|
||||
message Text Maybe
|
||||
hours Int
|
||||
UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique
|
||||
deriving Eq Read Show Generic
|
||||
|
||||
@ -24,6 +24,7 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Avs
|
||||
import Handler.Utils.Users
|
||||
import Handler.Health.Interface
|
||||
|
||||
import Handler.Admin.Test as Handler.Admin
|
||||
import Handler.Admin.ErrorMessage as Handler.Admin
|
||||
@ -54,13 +55,15 @@ getAdminProblemsR = do
|
||||
flagNonZero n | n <= 0 = flagError True
|
||||
| otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
|
||||
|
||||
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, interfaceTable) <- runDB $ (,,,,,)
|
||||
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,)
|
||||
<$> areAllUsersReachable
|
||||
<*> allDriversHaveAvsId now
|
||||
<*> allRDriversHaveFs now
|
||||
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime])
|
||||
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
|
||||
<*> fmap (view _2) (mkInterfaceLogTable flagError cutOffOldTime)
|
||||
<*> mkInterfaceLogTable flagError mempty
|
||||
let interfacesBadNr = length $ filter (not . snd) interfaceOks
|
||||
-- interfacesOk = all snd interfaceOks
|
||||
diffLics <- try retrieveDifferingLicences >>= \case
|
||||
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
|
||||
(Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
|
||||
@ -235,77 +238,3 @@ retrieveDriversRWithoutF now = do
|
||||
E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
|
||||
E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
|
||||
return usr
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
mkInterfaceLogTable :: (Bool -> Widget) -> UTCTime -> DB (Any, Widget)
|
||||
mkInterfaceLogTable flagError 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 (fromMaybe cutOffOldTime -> okTime) badInfo =
|
||||
void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True)
|
||||
(InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo))
|
||||
[InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null 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) okTime =<< mkBadInfo badRows badTime
|
||||
((E.Value True , E.Value okRows, E.Value okTime):_) ->
|
||||
writeAvsSynchStats (Just okRows) okTime mempty
|
||||
((E.Value False, E.Value badRows, E.Value badTime):_) -> do
|
||||
lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
|
||||
writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime
|
||||
_ -> return ()
|
||||
|
||||
let
|
||||
flagOld = flagError . (cutOffOldTime <)
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
resultILog :: Lens' (DBRow (Entity InterfaceLog)) InterfaceLog
|
||||
resultILog = _dbrOutput . _entityVal
|
||||
dbtSQLQuery = return
|
||||
dbtRowKey = (E.^. InterfaceLogId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable Nothing (textCell "Status" ) $ wgtCell . flagOld . view (resultILog . _interfaceLogTime)
|
||||
, sortable (Just "interface") (textCell "Interface" ) $ \(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 (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
|
||||
, sortable Nothing (textCell "Info" ) $ \(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 (E.^. InterfaceLogInterface)
|
||||
, singletonMap "subtype" $ SortColumn (E.^. InterfaceLogSubtype)
|
||||
, singletonMap "write" $ SortColumn (E.^. InterfaceLogWrite)
|
||||
, singletonMap "time" $ SortColumn (E.^. InterfaceLogTime)
|
||||
, singletonMap "rows" $ SortColumn (E.^. InterfaceLogRows)
|
||||
]
|
||||
dbtFilter = mempty
|
||||
dbtFilterUI = mempty
|
||||
dbtStyle = def
|
||||
dbtIdent = "interface-log" :: Text
|
||||
dbtParams = def
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
resultDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
|
||||
dbTable resultDBTableValidator resultDBTable
|
||||
@ -8,6 +8,8 @@
|
||||
module Handler.Health.Interface
|
||||
(
|
||||
getHealthInterfaceR
|
||||
, mkInterfaceLogTable
|
||||
, runInterfaceChecks
|
||||
)
|
||||
where
|
||||
|
||||
@ -17,7 +19,7 @@ import Import
|
||||
import qualified Data.Text as Text
|
||||
import Handler.Utils
|
||||
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
-- 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)
|
||||
@ -43,8 +45,39 @@ pbool (Text.toLower . Text.strip -> w)
|
||||
| w `elem` ["0", "f", "false","falsch"] = Just False
|
||||
| otherwise = Nothing
|
||||
|
||||
mkInterfaceLogTable :: [Unique InterfaceHealth] -> (Bool -> Widget) -> DB ([(Text,Bool)], Widget)
|
||||
mkInterfaceLogTable interfs flagError = do
|
||||
|
||||
|
||||
getHealthInterfaceR :: [Text] -> Handler Html
|
||||
getHealthInterfaceR ris = do
|
||||
let interfs = identifyInterfaces ris
|
||||
(missing, allok, res, iltable) <- runInterfaceLogTable interfs
|
||||
when missing notFound -- send 404 if an interface any interface was not found
|
||||
unless allok $ sendResponseStatus internalServerError500 $ "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
|
||||
siteLayoutMsg MsgMenuHealthInterface $ do
|
||||
setTitleI MsgMenuHealthInterface
|
||||
[whamlet|
|
||||
Interfaces healthy.
|
||||
|
||||
^{iltable}
|
||||
|]
|
||||
|
||||
|
||||
runInterfaceLogTable :: [Unique InterfaceHealth] -> Handler (Bool, Bool, [(Text,Bool)], Widget)
|
||||
runInterfaceLogTable interfs = 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) <- interfs, ifce `notElem` (fst <$> res) ]
|
||||
allok = all snd res
|
||||
return (missing, allok, res, twgt)
|
||||
|
||||
|
||||
mkInterfaceLogTable :: (Bool -> Widget) -> [Unique InterfaceHealth] -> DB ([(Text,Bool)], Widget)
|
||||
mkInterfaceLogTable flagError interfs = do
|
||||
runInterfaceChecks
|
||||
now <- liftIO getCurrentTime
|
||||
dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
|
||||
where
|
||||
@ -62,16 +95,14 @@ mkInterfaceLogTable interfs flagError = do
|
||||
| (UniqueInterfaceHealth ifce subt writ) <- interfs
|
||||
]
|
||||
let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead
|
||||
return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage)
|
||||
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, E.Value (Maybe Text))) InterfaceLog
|
||||
resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog
|
||||
resultILog = _dbrOutput . _1 . _entityVal
|
||||
resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Int
|
||||
resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int
|
||||
resultHours = _dbrOutput . _2 . E._unValue
|
||||
-- resultErrMsg :: Traversal' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Text
|
||||
-- resultErrMsg = _dbrOutput . _3 . E._unValue . _Just
|
||||
|
||||
dbtRowKey = queryILog >>> (E.^.InterfaceLogId)
|
||||
colonnade now = mconcat
|
||||
@ -88,6 +119,7 @@ mkInterfaceLogTable interfs flagError = do
|
||||
, 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
|
||||
@ -95,6 +127,7 @@ mkInterfaceLogTable interfs flagError = do
|
||||
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)
|
||||
@ -113,33 +146,44 @@ mkInterfaceLogTable interfs flagError = do
|
||||
dbtExtraReps = []
|
||||
|
||||
|
||||
-- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call
|
||||
runInterfaceChecks :: DB ()
|
||||
runInterfaceChecks = do
|
||||
avsInterfaceCheck
|
||||
lprAckCheck
|
||||
|
||||
lprAckCheck :: DB ()
|
||||
lprAckCheck = return () -- !!! TODO !!! Stub
|
||||
-- ensure that all received apc-idents were ok
|
||||
|
||||
getHealthInterfaceR :: [Text] -> Handler Html
|
||||
getHealthInterfaceR ris = do
|
||||
let interfs = identifyInterfaces ris
|
||||
res <- runDB $ E.select $ do
|
||||
(ilog :& ihealth) <- E.from (E.table @InterfaceLog
|
||||
`E.leftJoin` E.table @InterfaceHealth
|
||||
`E.on` (\(ilog :& ihealth) ->
|
||||
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 )
|
||||
))
|
||||
unless (null interfs) $
|
||||
E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce
|
||||
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt
|
||||
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ
|
||||
| (UniqueInterfaceHealth ifce subt writ) <- interfs
|
||||
]
|
||||
let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val 48)
|
||||
return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage)
|
||||
siteLayoutMsg MsgMenuHealthInterface $ do
|
||||
setTitleI MsgMenuHealthInterface
|
||||
[whamlet|
|
||||
TODO This page is not yet fully implemented
|
||||
|
||||
<ul>
|
||||
$forall i <- res
|
||||
<li>
|
||||
#{show i}
|
||||
|]
|
||||
avsInterfaceCheck :: DB ()
|
||||
avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \Entity{entityVal=InterfaceHealth{interfaceHealthHours}} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let cutOffOldTime = addHours (-interfaceHealthHours) now
|
||||
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 (fromMaybe cutOffOldTime -> okTime) badInfo =
|
||||
void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True)
|
||||
(InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo))
|
||||
[InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null 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) okTime =<< mkBadInfo badRows badTime
|
||||
((E.Value True , E.Value okRows, E.Value okTime):_) ->
|
||||
writeAvsSynchStats (Just okRows) okTime mempty
|
||||
((E.Value False, E.Value badRows, E.Value badTime):_) -> do
|
||||
lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
|
||||
writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime
|
||||
_ -> return ()
|
||||
|
||||
@ -56,8 +56,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<h2>
|
||||
_{MsgMenuInterfaces}
|
||||
<div>
|
||||
<p>
|
||||
_{MsgProblemsInterfaceSince} ^{formatTimeW SelFormatDate cutOffOldTime}
|
||||
<p>
|
||||
$if interfacesBadNr > 0
|
||||
_{MsgInterfacesFail interfacesBadNr}
|
||||
$else
|
||||
_{MsgInterfacesOk}
|
||||
^{interfaceTable}
|
||||
|
||||
<!-- section h2 {MsgProblemsHeadingMisc} -->
|
||||
|
||||
Reference in New Issue
Block a user