fix(health): fix #151 by offering route /health/interface/*

messages/uniworx/categories/admin/de-de-formal.msg

@@ -121,10 +121,13 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen
 ProblemsAvsErrorHeading: Fehlermeldungen
 ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit 
 
+InterfacesOk: Schnittstellen sind ok.
+InterfacesFail n@Int: #{tshow n} Schnittstellenprobleme!
 InterfaceStatus !ident-ok: Status
 InterfaceName: Schnittstelle
 InterfaceLastSynch: Zuletzt
 InterfaceSubtype: Betreffend
 InterfaceWrite: Schreibend
 InterfaceSuccess: Rückmeldung
-InterfaceInfo: Nachricht
+InterfaceInfo: Nachricht
+InterfaceFreshness: Prüfungszeitraum (h)

messages/uniworx/categories/admin/en-eu.msg

@@ -121,10 +121,13 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences
 ProblemsAvsErrorHeading: Error Log
 ProblemsInterfaceSince: Only considering successes and errors since 
 
+InterfacesOk: Interfaces are ok.
+InterfacesFail n: #{tshow n} Interface problems!
 InterfaceStatus: Status
 InterfaceName: Interface
 InterfaceLastSynch: Last
 InterfaceSubtype: Affecting
 InterfaceWrite: Write
 InterfaceSuccess: Returned
-InterfaceInfo: Message
+InterfaceInfo: Message
+InterfaceFreshness: Check hours

models/audit.model

@@ -26,7 +26,6 @@ InterfaceHealth
   interface Text
   subtype   Text Maybe
   write     Bool Maybe
-  hours     Int
+  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

src/Handler/Admin.hs

@@ -24,6 +24,7 @@ import qualified Database.Esqueleto.Utils as E
 import Handler.Utils
 import Handler.Utils.Avs
 import Handler.Utils.Users
+import Handler.Health.Interface
 
 import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
@@ -54,13 +55,15 @@ getAdminProblemsR = do
       flagNonZero n | n <= 0    = flagError True
                     | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))                                    
 
-  (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, interfaceTable) <- runDB $ (,,,,,) 
+  (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,) 
       <$> areAllUsersReachable 
       <*> allDriversHaveAvsId now
       <*> allRDriversHaveFs now
       <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime])
       <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])      
-      <*> fmap (view _2) (mkInterfaceLogTable flagError cutOffOldTime)
+      <*>  mkInterfaceLogTable flagError mempty
+  let interfacesBadNr = length $ filter (not . snd) interfaceOks
+      -- interfacesOk = all snd interfaceOks      
   diffLics <- try retrieveDifferingLicences >>= \case
     -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
     (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
@@ -235,77 +238,3 @@ retrieveDriversRWithoutF now = do
   E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
     E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
   return usr
-
-
-
-
-
-mkInterfaceLogTable :: (Bool -> Widget) -> UTCTime -> DB (Any, Widget)
-mkInterfaceLogTable flagError cutOffOldTime = do
-  avsSynchStats <- E.select $ do
-    uavs <- E.from $ E.table @UserAvs
-    E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime
-    let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError)
-    E.groupBy isOk
-    E.orderBy [E.descNullsLast isOk]
-    return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch)
-  let 
-    mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do
-      fmtCut <- formatTime SelFormatDate cutOffOldTime
-      fmtBad <- formatTime SelFormatDateTime badTime
-      return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad
-    mkBadInfo _ _ = return mempty
-    writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = 
-      void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True)
-        (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo))
-        [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo]
-  --case $(unValueN 3) <$> avsSynchStats of  
-  case avsSynchStats of 
-    ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) ->
-      writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime
-    ((E.Value True , E.Value okRows, E.Value okTime):_)    ->
-      writeAvsSynchStats (Just okRows) okTime mempty
-    ((E.Value False, E.Value badRows, E.Value badTime):_) -> do
-      lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
-      writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime
-    _ -> return ()
-  
-  let
-    flagOld       = flagError . (cutOffOldTime <)
-    resultDBTable = DBTable{..}
-      where
-        resultILog :: Lens' (DBRow (Entity InterfaceLog)) InterfaceLog
-        resultILog = _dbrOutput . _entityVal
-        dbtSQLQuery = return
-        dbtRowKey = (E.^. InterfaceLogId)
-        dbtProj = dbtProjId
-        dbtColonnade = dbColonnade $ mconcat
-          [ sortable Nothing            (textCell "Status"              ) $ wgtCell . flagOld . view (resultILog . _interfaceLogTime)
-          , sortable (Just "interface") (textCell "Interface"           ) $ \(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 Nothing            (textCell "Info"                ) $ \(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 (E.^. InterfaceLogInterface)
-          , singletonMap "subtype"   $ SortColumn (E.^. InterfaceLogSubtype)
-          , singletonMap "write"     $ SortColumn (E.^. InterfaceLogWrite)
-          , singletonMap "time"      $ SortColumn (E.^. InterfaceLogTime)
-          , singletonMap "rows"      $ SortColumn (E.^. InterfaceLogRows)          
-          ]
-        dbtFilter     = mempty
-        dbtFilterUI   = mempty
-        dbtStyle      = def
-        dbtIdent      = "interface-log" :: Text
-        dbtParams     = def
-        dbtCsvEncode  = noCsvEncode
-        dbtCsvDecode  = Nothing
-        dbtExtraReps  = []
-    resultDBTableValidator = def
-      & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
-  dbTable resultDBTableValidator resultDBTable

src/Handler/Health/Interface.hs

@@ -8,6 +8,8 @@
 module Handler.Health.Interface
   (
     getHealthInterfaceR
+  , mkInterfaceLogTable
+  , runInterfaceChecks
   )
  where
 
@@ -17,7 +19,7 @@ import Import
 import qualified Data.Text as Text
 import Handler.Utils
 
-import           Database.Esqueleto.Experimental ((:&)(..))
+-- 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)
@@ -43,8 +45,39 @@ pbool (Text.toLower . Text.strip -> w)
   | w `elem` ["0", "f", "false","falsch"]    = Just False
   | otherwise                                = Nothing
 
-mkInterfaceLogTable :: [Unique InterfaceHealth] -> (Bool -> Widget) -> DB ([(Text,Bool)], Widget)
+
-mkInterfaceLogTable interfs flagError = do
+
+getHealthInterfaceR :: [Text] -> Handler Html
+getHealthInterfaceR ris = do
+  let interfs = identifyInterfaces ris
+  (missing, allok, res, iltable) <- runInterfaceLogTable interfs  
+  when missing notFound -- send 404 if an interface any interface was not found
+  unless allok $ sendResponseStatus internalServerError500 $ "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
+  siteLayoutMsg MsgMenuHealthInterface $ do
+    setTitleI MsgMenuHealthInterface
+    [whamlet|
+      Interfaces healthy.
+
+      ^{iltable}
+    |]
+
+
+runInterfaceLogTable :: [Unique InterfaceHealth] -> Handler (Bool, Bool, [(Text,Bool)], Widget)
+runInterfaceLogTable interfs = do
+  -- we abuse messageTooltip for colored icons here
+  msgSuccessTooltip <- messageI Success MsgMessageSuccess
+  -- msgWarningTooltip <- messageI Warning MsgMessageWarning
+  msgErrorTooltip   <- messageI Error   MsgMessageError
+  let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
+  (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
+  let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- interfs, ifce `notElem` (fst <$> res) ]
+      allok   = all snd res
+  return (missing, allok, res, twgt)
+
+
+mkInterfaceLogTable :: (Bool -> Widget) -> [Unique InterfaceHealth] -> DB ([(Text,Bool)], Widget)
+mkInterfaceLogTable flagError interfs = do
+    runInterfaceChecks    
     now <- liftIO getCurrentTime
     dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
   where
@@ -62,16 +95,14 @@ mkInterfaceLogTable interfs flagError = do
                         | (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)
+      return (ilog, ihour)
 
     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    :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog
     resultILog    = _dbrOutput . _1 . _entityVal
-    resultHours   :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Int
+    resultHours   :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) 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
@@ -88,6 +119,7 @@ mkInterfaceLogTable interfs flagError = do
         , 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 Nothing            (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
         , 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
@@ -95,6 +127,7 @@ mkInterfaceLogTable interfs flagError = do
             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)
@@ -113,33 +146,44 @@ mkInterfaceLogTable interfs flagError = do
     dbtExtraReps  = []
 
 
+-- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call
+runInterfaceChecks :: DB ()
+runInterfaceChecks = do 
+  avsInterfaceCheck
+  lprAckCheck
+  
+lprAckCheck :: DB ()
+lprAckCheck = return () -- !!! TODO !!! Stub 
+  -- ensure that all received apc-idents were ok
 
-getHealthInterfaceR :: [Text] -> Handler Html
+avsInterfaceCheck :: DB ()  
-getHealthInterfaceR ris = do
+avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \Entity{entityVal=InterfaceHealth{interfaceHealthHours}} -> do
-  let interfs = identifyInterfaces ris
+  now <- liftIO getCurrentTime
-  res <- runDB $ E.select $ do
+  let cutOffOldTime = addHours (-interfaceHealthHours) now
-      (ilog :& ihealth) <- E.from (E.table @InterfaceLog
+  avsSynchStats <- E.select $ do
-            `E.leftJoin` E.table @InterfaceHealth
+    uavs <- E.from $ E.table @UserAvs
-            `E.on` (\(ilog :& ihealth) ->
+    E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime
-                      ilog E.^. InterfaceLogInterface E.=?.          ihealth E.?. InterfaceHealthInterface
+    let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError)
-                E.&&. ilog E.^. InterfaceLogSubtype   E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
+    E.groupBy isOk
-                E.&&. ilog E.^. InterfaceLogWrite     E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite  )
+    E.orderBy [E.descNullsLast isOk]
-              ))
+    return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch)
-      unless (null interfs) $
+  let 
-        E.where_ $ E.or [       ilog E.^. InterfaceLogInterface E.==. E.val ifce
+    mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do
-                          E.&&. ilog E.^. InterfaceLogSubtype   E.=~. E.val subt
+      fmtCut <- formatTime SelFormatDate cutOffOldTime
-                          E.&&. ilog E.^. InterfaceLogWrite     E.=~. E.val writ
+      fmtBad <- formatTime SelFormatDateTime badTime
-                        | (UniqueInterfaceHealth ifce subt writ) <- interfs
+      return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad
-                        ]
+    mkBadInfo _ _ = return mempty
-      let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val 48)
+    writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = 
-      return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage)
+      void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True)
-  siteLayoutMsg MsgMenuHealthInterface $ do
+        (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo))
-    setTitleI MsgMenuHealthInterface
+        [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo]
-    [whamlet|
+  --case $(unValueN 3) <$> avsSynchStats of  
-      TODO This page is not yet fully implemented
+  case avsSynchStats of 
-
+    ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) ->
-      <ul>
+      writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime
-        $forall i <- res
+    ((E.Value True , E.Value okRows, E.Value okTime):_)    ->
-          <li>
+      writeAvsSynchStats (Just okRows) okTime mempty
-            #{show i}
+    ((E.Value False, E.Value badRows, E.Value badTime):_) -> do
-    |]
+      lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
+      writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime
+    _ -> return ()

templates/admin-problems.hamlet

@@ -56,8 +56,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
   <h2>
     _{MsgMenuInterfaces}  
   <div>
-    <p>
+    <p> 
-      _{MsgProblemsInterfaceSince} ^{formatTimeW SelFormatDate cutOffOldTime}
+      $if interfacesBadNr > 0
+        _{MsgInterfacesFail interfacesBadNr}
+      $else
+        _{MsgInterfacesOk}
     ^{interfaceTable}
 
 <!-- section h2 {MsgProblemsHeadingMisc} -->