fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(health): WIP new interface health handlers

Browse Source
This commit is contained in:
Steffen Jost 2024-01-31 18:03:25 +01:00
parent 798a07e36c
commit a592ad7094
5 changed files with 84 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
models/audit.model
View File

@ -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
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

2
models/lms.model
View File

@ -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

30
routes
View File

@ -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

11
src/Database/Esqueleto/Utils.hs
View File

@ -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 '\''

46
src/Handler/Health/Interfaces.hs Normal file
View File

@ -0,0 +1,46 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- 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