diff --git a/models/audit.model b/models/audit.model index 6a1277b7a..defb5c391 100644 --- a/models/audit.model +++ b/models/audit.model @@ -20,4 +20,13 @@ InterfaceLog info Text -- addtional status information success Bool default=true -- false logs a failure; but it will be overwritten by next transaction, but logged in TransactionLog UniqueInterfaceSubtypeWrite interface subtype write - deriving Eq Read Show Generic \ No newline at end of file + deriving Eq Read Show Generic + +InterfaceHealth + interface Text + subtype Text Maybe + write Bool Maybe + hours Int + message Text Maybe + UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique + deriving Eq Read Show Generic diff --git a/models/lms.model b/models/lms.model index d9f4c1b7e..9e96df730 100644 --- a/models/lms.model +++ b/models/lms.model @@ -20,7 +20,7 @@ Qualification SchoolQualificationShort school shorthand -- must be unique per school and shorthand SchoolQualificationName school name -- must be unique per school and name -- across all schools, only one qualification may be a driving licence: - UniqueQualificationAvsLicence avsLicence !force + UniqueQualificationAvsLicence avsLicence !force -- either empty or unique -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints! deriving Eq Generic diff --git a/routes b/routes index 752405690..ab8d094ae 100644 --- a/routes +++ b/routes @@ -84,20 +84,22 @@ /print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer /print/log PrintLogR GET !system-printer -/health HealthR GET !free -/instance InstanceR GET !free -/info InfoR GET !free -/info/lecturer InfoLecturerR GET !free -/info/supervisor InfoSupervisorR GET !free -/info/legal LegalR GET !free -/info/glossary GlossaryR GET !free -/info/faq FaqR GET !free -/info/terms-of-use TermsOfUseR GET !free -/info/payments PaymentsR GET !free -/imprint ImprintR GET !free -/data-protection DataProtectionR GET !free -/version VersionR GET !free -/status StatusR GET !free +/health HealthR GET !free +/health/interfaces HealthInterfacesR GET !free +/health/interface/*Text HealthInterfaceR GET !free +/instance InstanceR GET !free +/info InfoR GET !free +/info/lecturer InfoLecturerR GET !free +/info/supervisor InfoSupervisorR GET !free +/info/legal LegalR GET !free +/info/glossary GlossaryR GET !free +/info/faq FaqR GET !free +/info/terms-of-use TermsOfUseR GET !free +/info/payments PaymentsR GET !free +/imprint ImprintR GET !free +/data-protection DataProtectionR GET !free +/version VersionR GET !free +/status StatusR GET !free /help HelpR GET POST !free diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 1e8ecfe7e..65e826b34 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -700,6 +700,17 @@ dayMaybe = E.unsafeSqlCastAs "date" interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- 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 + +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 '\'' diff --git a/src/Handler/Health/Interfaces.hs b/src/Handler/Health/Interfaces.hs new file mode 100644 index 000000000..8c87ee7c7 --- /dev/null +++ b/src/Handler/Health/Interfaces.hs @@ -0,0 +1,46 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.Health.Interfaces where + +import Import + +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Utils as E + + +getHealthInterfacesR :: Handler Html +getHealthInterfacesR = auxHealthInterfaces [] + +getHealthInterfaceR :: [Text] -> Handler Html +getHealthInterfaceR ["*"] = auxHealthInterfaces [] +getHealthInterfaceR [i] = auxHealthInterfaces [(i, Nothing, Nothing)] +getHealthInterfaceR [i,s] = auxHealthInterfaces [(i, Just s, Nothing)] +getHealthInterfaceR [i,s, Text.toLower . Text.strip -> w] + | w `elem` ["1", "t", "true" ,"wahr", "w"] = auxHealthInterfaces [(i, Just s, Just True )] + | w `elem` ["0", "f", "false","falsch"] = auxHealthInterfaces [(i, Just s, Just False)] +-- TODO: also allow '*' for wildcards and cycle; better write separate parse function +getHealthInterfaceR _ = notFound + + +auxHealthInterfaces :: [(Text, Maybe Text, Maybe Bool)] -> Handler Html +auxHealthInterfaces interfs = do + _TODO <- 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.^. InterfaceInterface E.==. E.val ifce + E.&&. ilog E.^. InterfaceSubtype E.=~. E.val subt + E.&&. ilog E.^. InterfaceWrite E.=~. E.val writ + | (ifce, subt, writ) <- interfs + ] + let ihour = E.coalesceDefault [E.joinV (ihealth E.?. InterfaceHealthHours)] (E.val 48) + return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) + notFound \ No newline at end of file