From bbb9f9fadb4136a92fa6727cb73ee02eb489f495 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Feb 2024 17:16:19 +0100 Subject: [PATCH] chore(health): telling interface table compiles --- .../uniworx/categories/admin/de-de-formal.msg | 6 +- messages/uniworx/categories/admin/en-eu.msg | 6 +- src/Handler/Health/Interface.hs | 89 +++++++++++++++++-- src/Handler/LMS/Report.hs | 3 +- src/Handler/Utils/DateTime.hs | 4 +- 5 files changed, 95 insertions(+), 13 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index f4c23696d..ad521c490 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -121,6 +121,10 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit +InterfaceStatus !ident-ok: Status +InterfaceName: Schnittstelle InterfaceLastSynch: Zuletzt InterfaceSubtype: Betreffend -InterfaceWrite: Schreibend \ No newline at end of file +InterfaceWrite: Schreibend +InterfaceSuccess: Rückmeldung +InterfaceInfo: Nachricht \ 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 c035f54c0..c73fd8910 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -121,6 +121,10 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since +InterfaceStatus: Status +InterfaceName: Interface InterfaceLastSynch: Last InterfaceSubtype: Affecting -InterfaceWrite: Write \ No newline at end of file +InterfaceWrite: Write +InterfaceSuccess: Returned +InterfaceInfo: Message \ No newline at end of file diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 6592b6f56..e623901f1 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -2,6 +2,9 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- !!! TODO REMOVE ME + + module Handler.Health.Interface ( getHealthInterfaceR @@ -12,10 +15,12 @@ import Import -- import qualified Data.Set as Set import qualified Data.Text as Text +import Handler.Utils 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) identifyInterfaces :: [Text] -> [Unique InterfaceHealth] @@ -34,35 +39,105 @@ 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` ["1", "t", "true" ,"wahr", "w"] = Just True | w `elem` ["0", "f", "false","falsch"] = Just False | otherwise = Nothing +mkInterfaceLogTable :: [Unique InterfaceHealth] -> (Bool -> Widget) -> DB ([(Text,Bool)], Widget) +mkInterfaceLogTable interfs flagError = do + now <- liftIO getCurrentTime + dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} + where + 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 ) + ) + 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 $ 3 * 24) -- if no default time is set, use 3 days instead + return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) + + 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 = _dbrOutput . _1 . _entityVal + resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) 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 + [ 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 && 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 (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 = [] + + getHealthInterfaceR :: [Text] -> Handler Html getHealthInterfaceR ris = do let interfs = identifyInterfaces ris res <- runDB $ E.select $ do - (ilog :& ihealth) <- E.from (E.table @InterfaceLog + (ilog :& ihealth) <- E.from (E.table @InterfaceLog `E.leftJoin` E.table @InterfaceHealth - `E.on` (\(ilog :& ihealth) -> + `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) $ + 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) + ] + 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 - +