diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index d7d246ed3..502f3d09f 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 02e25ca1e..9fcb4b2a6 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/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 diff --git a/src/Audit.hs b/src/Audit.hs index a01491b35..03038df1b 100644 --- a/src/Audit.hs +++ b/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 - 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 } - \ No newline at end of file + auditHelper transaction TransactionLog + { transactionLogTime = interfaceLogTime + , transactionLogInstance = interfaceLogInstance + , transactionLogInitiator = interfaceLogInitiator + , transactionLogRemote = interfaceLogRemote + , transactionLogInfo = toJSON transaction + } diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 0340bc41f..aaf2d32d7 100644 --- a/src/Handler/Admin.hs +++ b/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 - 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 \ No newline at end of file diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index ff329166e..380935740 100644 --- a/src/Handler/LMS/Learners.hs +++ b/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 \ No newline at end of file diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index c95f13a1f..77c5f0a6a 100644 --- a/src/Handler/LMS/Report.hs +++ b/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." diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 8c4be014a..c30c8a0c7 100644 --- a/src/Handler/SAP.hs +++ b/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: diff --git a/src/Handler/Submission/Helper/ArchiveTable.hs b/src/Handler/Submission/Helper/ArchiveTable.hs index 737440df2..05062d1a1 100644 --- a/src/Handler/Submission/Helper/ArchiveTable.hs +++ b/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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index a1ca0a18a..3994b81f0 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/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 - | otherwise = textCell content + | length content > 32 = modalCell content + | otherwise = stringCell content markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a markupCellLargeModal mup diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 0d5182704..3b8888837 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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 = 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 diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index f53c22d23..de9608a4d 100644 --- a/src/Utils/DB.hs +++ b/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 diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index fb2771e85..07804c015 100644 --- a/src/Utils/Icon.hs +++ b/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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 5c83e1e35..5e5f993c6 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -309,6 +309,8 @@ makeLenses_ ''AuthorshipStatementDefinition makeLenses_ ''PrintJob +makeLenses_ ''InterfaceLog + -------------------------- -- Fields for `UniWorX` -- -------------------------- diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index 60ffd4d92..0754f5104 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -43,7 +43,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
^{simpleLinkI MsgProblemsUsersAreReachable ProblemUnreachableR}
^{flagError noStalePrintJobs} -
^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR} +
^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffOldDays) PrintCenterR}
^{flagError noBadAPCids}
_{MsgProblemsNoBadAPCIds} @@ -54,7 +54,15 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

- _{MsgProblemsHeadingMisc} -
-
^{flagError noAvsSynchProblems} -
^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR} + _{MsgMenuInterfaces} + +
+
+
^{flagError noAvsSynchProblems} +
^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR} + +
+ ^{interfaceTable} + + +