chore(health): telling interface table compiles

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

@@ -121,6 +121,10 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen
 ProblemsAvsErrorHeading: Fehlermeldungen
 ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit 
 
+InterfaceStatus !ident-ok: Status
+InterfaceName: Schnittstelle
 InterfaceLastSynch: Zuletzt
 InterfaceSubtype: Betreffend
-InterfaceWrite: Schreibend
+InterfaceWrite: Schreibend
+InterfaceSuccess: Rückmeldung
+InterfaceInfo: Nachricht

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

@@ -121,6 +121,10 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences
 ProblemsAvsErrorHeading: Error Log
 ProblemsInterfaceSince: Only considering successes and errors since 
 
+InterfaceStatus: Status
+InterfaceName: Interface
 InterfaceLastSynch: Last
 InterfaceSubtype: Affecting
-InterfaceWrite: Write
+InterfaceWrite: Write
+InterfaceSuccess: Returned
+InterfaceInfo: Message

src/Handler/Health/Interface.hs

@@ -2,6 +2,9 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}    -- !!! TODO REMOVE ME
+
+
 module Handler.Health.Interface
   (
     getHealthInterfaceR
@@ -12,10 +15,12 @@ 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]
@@ -34,35 +39,105 @@ 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` ["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 
+      (ilog :& ihealth) <- E.from (E.table @InterfaceLog
             `E.leftJoin` E.table @InterfaceHealth
-            `E.on` (\(ilog :& ihealth) -> 
+            `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) $ 
+      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)    
+      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>

src/Handler/LMS/Report.hs

@@ -294,8 +294,7 @@ postLmsReportUploadR sid qsh = do
         setTitleI MsgMenuLmsUpload
         [whamlet|$newline never
           <form method=post enctype=#{enctype}>
-            ^{widget}
+            ^{widget}            
-            <p>
             <input type=submit>
         |]
 

src/Handler/Utils/DateTime.hs

@@ -93,8 +93,8 @@ toMorning = toTimeOfDay 6 0 0
 toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime
 toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..}
 
-addHours :: Integer -> UTCTime -> UTCTime
+addHours :: Integral n => n -> UTCTime -> UTCTime
-addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600)
+addHours = addUTCTime . secondsToNominalDiffTime . fromIntegral . (* 3600)
 
 instance HasLocalTime UTCTime where
   toLocalTime = utcToLocalTime