diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index ad521c490..6fb6a2836 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -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 \ No newline at end of file +InterfaceInfo: Nachricht +InterfaceFreshness: Prüfungszeitraum (h) \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index c73fd8910..74420ff19 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -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 \ No newline at end of file +InterfaceInfo: Message +InterfaceFreshness: Check hours \ No newline at end of file diff --git a/models/audit.model b/models/audit.model index defb5c391..3cd567a13 100644 --- a/models/audit.model +++ b/models/audit.model @@ -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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 92dcac020..fd001c768 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -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 \ No newline at end of file diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index e623901f1..d1b8a0af0 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -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 - -