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

chore(health): stub that compiles

Browse Source
This commit is contained in:
Steffen Jost 2024-02-01 10:35:31 +01:00
parent a592ad7094
commit 47f853bd4a
8 changed files with 89 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -23,6 +23,7 @@ MenuPayments: Zahlungsbedingungen
MenuInstance: Instanz-Identifikation
MenuHealth: Instanz-Zustand
MenuHealthInterface: Schnittstellen Zustand
MenuHelp: Hilfe
MenuProfile: Anpassen
MenuLogin !ident-ok: Login

1
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -23,6 +23,7 @@ MenuPayments: Payment Terms
MenuInstance: Instance identification
MenuHealth: Instance health
MenuHealthInterface: Interface health
MenuHelp: Support
MenuProfile: Settings
MenuLogin: Login

3
routes
View File

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

1
src/Application.hs
View File

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

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

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

18
src/Foundation/Navigation.hs
View File

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

70
src/Handler/Health/Interface.hs Normal file
View File

@ -0,0 +1,70 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- 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
<ul>
$forall i <- res
<li>
#{show i}
|]

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

@ -1,46 +0,0 @@
-- 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