146 lines
7.3 KiB
Haskell
146 lines
7.3 KiB
Haskell
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- !!! TODO REMOVE ME
|
|
|
|
|
|
module Handler.Health.Interface
|
|
(
|
|
getHealthInterfaceR
|
|
)
|
|
where
|
|
|
|
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]
|
|
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
|
|
|
|
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
|
|
`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}
|
|
|]
|