chore(admin): show lms and sap interface status on problem page

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -136,6 +136,7 @@ MenuFirmUsers: Angehörige
 MenuFirmSupervisors: Ansprechpartner
 MenuFirmsComm: Mitteilung
 
+MenuInterfaces: Schnittstellen
 MenuSap: SAP Schnittstelle
 
 MenuAvs: AVS Schnittstelle

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -70,7 +70,6 @@ MenuCourseDelete: Delete course
 MenuSubmissionNew: Create submission
 MenuSubmissionOwn: Submission
 MenuCorrectors: Correctors
-
 MenuSheetEdit: Edit exercise sheet
 MenuSheetDelete: Delete exercise sheet
 MenuSheetClone: Clone exercise sheet
@@ -137,6 +136,7 @@ MenuFirmUsers: Associates
 MenuFirmSupervisors: Supervisors
 MenuFirmsComm: Messaging
 
+MenuInterfaces: Interfaces
 MenuSap: SAP Interface 
 
 MenuAvs: AVS Interface

src/Audit.hs

@@ -104,18 +104,24 @@ audit :: ( AuthId (HandlerSite m) ~ Key User
 --   - `transactionLogInitiator` is currently logged in user (or none)
 --   - `transactionLogRemote` is determined from current HTTP-Request
 audit transaction@(toJSON -> transactionLogInfo) = do
-
   transactionLogTime <- liftIO getCurrentTime
   transactionLogInstance <- getsYesod $ view instanceID
   transactionLogInitiator <- liftHandler maybeAuthId
   transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
+  auditHelper transaction TransactionLog{..}
 
-  insert_ TransactionLog{..}
+auditHelper :: (
-
+           IsSqlBackend (YesodPersistBackend (HandlerSite m))
+         , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
+         , MonadHandler m         
+         , HasCallStack
+         )
+      => Transaction -> TransactionLog -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
+auditHelper transaction tl@TransactionLog{..} = do 
+  insert_ tl
   $logInfoS "Audit" $ Text.filter (/= '\n') $ tshow (transaction, transactionLogInitiator, transactionLogRemote) <> " - " <> pack (prettyCallStack callStack)
 
-
+logInterface :: ( AuthId (HandlerSite m) ~ Key User
-logInterface :: ( AuthId (HandlerSite m) ~ Key User 
          , IsSqlBackend (YesodPersistBackend (HandlerSite m))
          , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
          , HasInstanceID (HandlerSite m) InstanceId
@@ -139,12 +145,19 @@ logInterface interfaceLogInterface interfaceLogSubtype interfaceLogInfo = do
   interfaceLogInstance <- getsYesod $ view instanceID
   interfaceLogInitiator <- liftHandler maybeAuthId
   interfaceLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
-  interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
+  interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest  
-  putMany [InterfaceLog{..}]
+  deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest
-  audit TransactionInterface
+  insert_ InterfaceLog{..}
+  let transaction = TransactionInterface
           { transactionInterfaceName    = interfaceLogInterface
           , transactionInterfaceSubtype = interfaceLogSubtype
           , transactionInterfaceInfo    = interfaceLogInfo
           , transactionInterfaceWrite   = interfaceLogWrite
           }
-  
+  auditHelper transaction TransactionLog 
+          { transactionLogTime      = interfaceLogTime
+          , transactionLogInstance  = interfaceLogInstance
+          , transactionLogInitiator = interfaceLogInitiator
+          , transactionLogRemote    = interfaceLogRemote
+          , transactionLogInfo      = toJSON transaction
+          }

src/Handler/Admin.hs

@@ -21,11 +21,9 @@ import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E
 import qualified Database.Esqueleto.Utils as E
 
-import Handler.Utils.DateTime
+import Handler.Utils
 import Handler.Utils.Avs
-import Handler.Utils.Widgets
 import Handler.Utils.Users
-import Handler.Utils.Qualification
 
 import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
@@ -42,22 +40,35 @@ getAdminProblemsR :: Handler Html
 getAdminProblemsR = do 
   now <- liftIO getCurrentTime
   let nowaday = utctDay now
-      cutOffPrintDays = 7
+      cutOffOldDays = 7
-      cutOffPrintJob  = addLocalDays  (-cutOffPrintDays) now      
+      cutOffOldTime  = addLocalDays  (-cutOffOldDays) now      
 
-  (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, noAvsSynchProblems) <- runDB $ (,,,,,) 
+  -- 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
+      flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
+      flagOld     = flagError . (cutOffOldTime <)
+      flagNonZero :: Int -> Widget
+      flagNonZero n | n <= 0    = flagError True
+                    | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))                                    
+
+  (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, noAvsSynchProblems, interfaceTable) <- runDB $ (,,,,,,) 
       <$> areAllUsersReachable 
       <*> allDriversHaveAvsId now
       <*> allRDriversHaveFs now
-      <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <=. cutOffPrintJob])
+      <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime])
       <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
-      <*> (not <$> exists [UserAvsLastSynchError !=. Nothing])    
+      <*> (not <$> exists [UserAvsLastSynchError !=. Nothing])
+      <*> fmap (view _2) (mkInterfaceLogTable flagOld)
   diffLics <- try retrieveDifferingLicences >>= \case
     -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
     (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
     (Right AvsLicenceDifferences{..}) -> do
-      let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld      
+      let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
-      forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday)      
+      forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday)
       return $ Right
         ( Set.size avsLicenceDiffRevokeAll
         , Set.size avsLicenceDiffGrantVorfeld
@@ -72,18 +83,7 @@ getAdminProblemsR = do
   --                          ex             -> return $ Left $ text2widget $ tshow ex)
   --   , Catch.Handler (\(ex::SomeException) -> return $ Left $ text2widget $ tshow ex)
   --   ]
-      
-  -- 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
-      flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
-      flagNonZero :: Int -> Widget
-      flagNonZero n | n <= 0    = flagError True
-                    | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))                                    
-  
   rerouteMail <- getsYesod $ view _appMailRerouteTo
 
   siteLayoutMsg MsgProblemsHeading $ do
@@ -237,4 +237,39 @@ retrieveDriversRWithoutF now = do
   E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
     E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
   return usr
-  
+
+
+mkInterfaceLogTable :: (UTCTime -> Widget) -> DB (Any, Widget)
+mkInterfaceLogTable flagOld = do
+  let
+    resultDBTable = DBTable{..}
+      where
+        resultILog :: Lens' (DBRow (Entity InterfaceLog)) InterfaceLog
+        resultILog = _dbrOutput . _entityVal
+        dbtSQLQuery = return
+        dbtRowKey = (E.^. InterfaceLogId)
+        dbtProj = dbtProjId
+        dbtColonnade = dbColonnade $ mconcat
+          [ sortable Nothing             mempty                 $ wgtCell . flagOld . view (resultILog . _interfaceLogTime)
+          , sortable (Just "interface") (textCell "Interface")  $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
+          , sortable (Just "subtype")   (textCell "Art"      )  $ textCell . view (resultILog . _interfaceLogSubtype)
+          , sortable (Just "write")     (textCell "Write"    )  $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
+          , sortable Nothing            (textCell "Info"     )  $ textCell . view (resultILog . _interfaceLogInfo)
+          , sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ dateTimeCell . view (resultILog . _interfaceLogTime)
+          ]
+        dbtSorting = mconcat
+          [ singletonMap "interface" $ SortColumn (E.^. InterfaceLogInterface)
+          , singletonMap "subtype"   $ SortColumn (E.^. InterfaceLogSubtype)
+          , singletonMap "write"     $ SortColumn (E.^. InterfaceLogWrite)
+          , singletonMap "time"      $ SortColumn (E.^. InterfaceLogTime)
+          ]
+        dbtFilter     = mempty
+        dbtFilterUI   = mempty
+        dbtStyle      = def
+        dbtIdent      = "interface-log" :: Text
+        dbtParams     = def
+        dbtCsvEncode  = noCsvEncode
+        dbtCsvDecode  = Nothing
+        dbtExtraReps  = []
+    resultDBTableValidator = def
+  dbTable resultDBTableValidator resultDBTable

src/Handler/LMS/Learners.hs

@@ -209,10 +209,10 @@ getLmsLearnersDirectR sid qsh = do
       csvOpts = def { csvFormat = fmtOpts }
   csvSheetName <- csvFilenameLmsUser qsh
   let nr  = length lms_users
-      msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"  
+      msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
   $logInfoS "LMS" msg
   addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
-  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered  
+  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
-
+    <* runDB (logInterface "LMS" (ciOriginal qsh) (tshow nr <> " rows"))
 -- direct Download see:
 -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

src/Handler/LMS/Report.hs

@@ -321,6 +321,7 @@ postLmsReportDirectR sid qsh = do
             let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ".  "
             $logInfoS "LMS" msg
             when (nr > 0) $ queueDBJob $ JobLmsReports qid
+            logInterface "LMS" (ciOriginal qsh) (tshow nr <> " rows")
             return (ok200, msg)
     []     -> do
       let msg = "Report upload file missing."

src/Handler/SAP.hs

@@ -137,11 +137,11 @@ getQualificationSAPDirectR = do
       csvOpts = def { csvFormat = fmtOpts }
       csvSheetName = "fradrive_sap_" <> fdate <> ".csv"
       nr  = length qualUsers
-      msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"  
+      msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
   $logInfoS "SAP" msg
-  runDB $ logInterface "SAP" "" $ tshow $ length csvRendered
+  let logInt = runDB $ logInterface "SAP" "" $ tshow nr <> " rows"
   addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
-  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered  
+  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt
   
 
 -- direct Download see:

src/Handler/Submission/Helper/ArchiveTable.hs

@@ -74,7 +74,7 @@ mkSubmissionArchiveTable tid ssh csh shn showCorrection smid = do
               isFile' = origIsFile <|> corrIsFile
             in maybeCell ((,) <$> fileTitle'' <*> isFile') $ \(fileTitle', isFile) -> if
               | Just True <- origIsFile -> anchorCell (subDownloadLink SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
-              | otherwise               -> textCell $ bool (<> "/") id isFile fileTitle'
+              | otherwise               -> stringCell $ bool (<> "/") id isFile fileTitle'
         , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgTableCorState) $ \t -> case t ^? resultCorrected of
             Nothing -> cell mempty
             Just (Entity _ SubmissionFile{..}) -> tellCell (Any True) $ if

src/Handler/Utils/Table/Cells.hs

@@ -158,8 +158,8 @@ modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget
 -- | Show Text if it is small, create modal otherwise
 modalCellLarge :: (IsDBTable m a, ToWidget UniWorX t, MonoFoldable t, Element t ~ Char) => t -> DBCell m a
 modalCellLarge content 
-  | length content > 32 = modalCell content
+  | length content > 32 = modalCell  content
-  | otherwise           = textCell  content
+  | otherwise           = stringCell content
 
 markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a
 markupCellLargeModal mup

src/Handler/Utils/Table/Pagination.hs

@@ -1711,9 +1711,11 @@ cell wgt = dbCell # ([], return wgt)
 wgtCell :: (IsDBTable m a, ToWidget UniWorX wgt) => wgt -> DBCell m a
 wgtCell = cell . toWidget
 
-textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a
+textCell :: (IsDBTable m a) => Text -> DBCell m a
-textCell = cell . toWidget . (pack :: String -> Text) . otoList
+textCell = wgtCell
-stringCell = textCell
+
+stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a
+stringCell = wgtCell . (pack :: String -> Text) . otoList
 
 i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
 i18nCell msg = cell $ do

src/Utils/DB.hs

@@ -97,6 +97,15 @@ updateBy uniq updates = do
 updateGetEntity :: (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m (Entity record)
 updateGetEntity k = fmap (Entity k) . updateGet k
 
+-- | insert or replace a record based on a single uniqueness constraint
+--   this function was meant to be supplied with the uniqueness constraint, but it would be unsafe if the uniqueness constraint would not match the supplied record
+replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend) 
+              => record -> ReaderT backend m ()
+replaceBy r = do 
+  u <- onlyUnique r
+  deleteBy u
+  insert_ r
+
 -- | Like 'myReplaceUnique' or 'replaceUnique' but with reversed result: returns 'Nothing' if the replacement was not possible,
 --   and 'Just key' for the successfully replaced record
 uniqueReplace :: ( MonadIO m

src/Utils/Icon.hs

@@ -116,6 +116,7 @@ data Icon
   | IconUnlocked
   | IconResetTries -- also see IconReset
   | IconCompany
+  | IconEdit
   | IconUserEdit
   
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
@@ -211,6 +212,7 @@ iconText = \case
     IconUnlocked                -> "lock-open-alt"
     IconResetTries              -> "trash-undo"
     IconCompany                 -> "building"
+    IconEdit                    -> "edit"
     IconUserEdit                -> "user-edit"
 
 nullaryPathPiece ''Icon $ camelToPathPiece' 1

src/Utils/Lens.hs

@@ -309,6 +309,8 @@ makeLenses_ ''AuthorshipStatementDefinition
 
 makeLenses_ ''PrintJob
 
+makeLenses_ ''InterfaceLog
+
 --------------------------
 -- Fields for `UniWorX` --
 --------------------------

templates/admin-problems.hamlet

@@ -43,7 +43,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
     <dd .deflist__dd>^{simpleLinkI MsgProblemsUsersAreReachable ProblemUnreachableR}
 
     <dt .deflist__dt>^{flagError noStalePrintJobs}
-    <dd .deflist__dd>^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR}
+    <dd .deflist__dd>^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffOldDays) PrintCenterR}
 
     <dt .deflist__dt>^{flagError noBadAPCids}
     <dd .deflist__dd>_{MsgProblemsNoBadAPCIds}
@@ -54,7 +54,15 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
   <h2>
-    _{MsgProblemsHeadingMisc}
+    _{MsgMenuInterfaces}
-  <dl .deflist>
+
-    <dt .deflist__dt>^{flagError noAvsSynchProblems}
+  <div>     
-    <dd .deflist__dd>^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR}
+    <dl .deflist>
+      <dt .deflist__dt>^{flagError noAvsSynchProblems}
+      <dd .deflist__dd>^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR}
+
+  <div>
+    ^{interfaceTable}
+
+<!-- section h2 {MsgProblemsHeadingMisc} -->
+