From 47f853bd4af0c639a736e149bbeeef73438bc032 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 1 Feb 2024 10:35:31 +0100 Subject: [PATCH] chore(health): stub that compiles --- .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 3 +- src/Application.hs | 1 + src/Database/Esqueleto/Utils.hs | 12 ---- src/Foundation/Navigation.hs | 18 ++++- src/Handler/Health/Interface.hs | 70 +++++++++++++++++++ src/Handler/Health/Interfaces.hs | 46 ------------ 8 files changed, 89 insertions(+), 63 deletions(-) create mode 100644 src/Handler/Health/Interface.hs delete mode 100644 src/Handler/Health/Interfaces.hs diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index a2b93a00d..c94663cfc 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -23,6 +23,7 @@ MenuPayments: Zahlungsbedingungen MenuInstance: Instanz-Identifikation MenuHealth: Instanz-Zustand +MenuHealthInterface: Schnittstellen Zustand MenuHelp: Hilfe MenuProfile: Anpassen MenuLogin !ident-ok: Login diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 6fe895c22..e09c56ef1 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -23,6 +23,7 @@ MenuPayments: Payment Terms MenuInstance: Instance identification MenuHealth: Instance health +MenuHealthInterface: Interface health MenuHelp: Support MenuProfile: Settings MenuLogin: Login diff --git a/routes b/routes index ab8d094ae..41f6d1f90 100644 --- a/routes +++ b/routes @@ -85,8 +85,7 @@ /print/log PrintLogR GET !system-printer /health HealthR GET !free -/health/interfaces HealthInterfacesR GET !free -/health/interface/*Text HealthInterfaceR GET !free +/health/interface/+Texts HealthInterfaceR GET !free /instance InstanceR GET !free /info InfoR GET !free /info/lecturer InfoLecturerR GET !free diff --git a/src/Application.hs b/src/Application.hs index 45f24768e..4b60ecb39 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -145,6 +145,7 @@ import Handler.Material import Handler.CryptoIDDispatch import Handler.SystemMessage import Handler.Health +import Handler.Health.Interface import Handler.Exam import Handler.ExamOffice import Handler.Metrics diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 65e826b34..8a0a02a17 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -705,18 +705,6 @@ interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text singleQuote = Text.Builder.singleton '\'' wrapSqlString b = singleQuote <> b <> singleQuote -addHours :: E.SqlExpr (E.Value Int) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value UTCTime) -addHours - -- E.+=. requires both types to be the same, so we use Day --- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example - - -interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show - where - singleQuote = Text.Builder.singleton '\'' - wrapSqlString b = singleQuote <> b <> singleQuote - - infixl 6 `diffDays`, `diffTimes` diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 374b4d566..72095a86d 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -165,9 +165,10 @@ breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing -breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing -breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing -breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed +breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing +breadcrumb (HealthInterfaceR _) = i18nCrumb MsgMenuHealthInterface (Just HealthR) +breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing +breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs @@ -1334,6 +1335,17 @@ pageActions HealthR = return } , navChildren = [] } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuHealthInterface + , navRoute = HealthInterfaceR [] + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } ] pageActions InstanceR = return [ NavPageActionPrimary diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs new file mode 100644 index 000000000..6592b6f56 --- /dev/null +++ b/src/Handler/Health/Interface.hs @@ -0,0 +1,70 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.Health.Interface + ( + getHealthInterfaceR + ) + where + +import Import + +-- import qualified Data.Set as Set +import qualified Data.Text as Text + +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Utils as E + + +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 + +-- | identify a wildcard argument +wc2null :: Text -> Maybe Text +wc2null "." = Nothing +-- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface +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 + + +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 + +