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

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

Browse Source
This commit is contained in:
Steffen Jost 2023-12-07 13:16:55 +01:00
parent c334fa4bf3
commit 0b9a1257db
14 changed files with 122 additions and 49 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

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

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

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

31
src/Audit.hs
View File

@ -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
putMany [InterfaceLog{..}]
audit TransactionInterface
interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest
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
}

79
src/Handler/Admin.hs
View File

@ -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
cutOffPrintJob = addLocalDays (-cutOffPrintDays) now
cutOffOldDays = 7
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
forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday)
let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
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

6
src/Handler/LMS/Learners.hs
View File

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

1
src/Handler/LMS/Report.hs
View File

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

6
src/Handler/SAP.hs
View File

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

2
src/Handler/Submission/Helper/ArchiveTable.hs
View File

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

4
src/Handler/Utils/Table/Cells.hs
View File

@ -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
| otherwise = textCell content
| length content > 32 = modalCell content
| otherwise = stringCell content
markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a
markupCellLargeModal mup

8
src/Handler/Utils/Table/Pagination.hs
View File

@ -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 = cell . toWidget . (pack :: String -> Text) . otoList
stringCell = textCell
textCell :: (IsDBTable m a) => Text -> DBCell m a
textCell = wgtCell
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

9
src/Utils/DB.hs
View File

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

2
src/Utils/Icon.hs
View File

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

2
src/Utils/Lens.hs
View File

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

18
templates/admin-problems.hamlet
View File

@ -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}
<dl .deflist>
<dt .deflist__dt>^{flagError noAvsSynchProblems}
<dd .deflist__dd>^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR}
_{MsgMenuInterfaces}
<div>
<dl .deflist>
<dt .deflist__dt>^{flagError noAvsSynchProblems}
<dd .deflist__dd>^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR}
<div>
^{interfaceTable}
<!-- section h2 {MsgProblemsHeadingMisc} -->