From fd388b91f452c3c85d0aef67af8e5376afcae237 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 30 Jan 2024 18:42:13 +0100 Subject: [PATCH] chore(lpr): error log as interface log --- models/audit.model | 7 +++--- src/Audit.hs | 4 ++- src/Audit/Types.hs | 1 + src/Handler/Admin.hs | 8 +++--- src/Handler/LMS/Learners.hs | 2 +- src/Handler/LMS/Report.hs | 3 ++- src/Handler/PrintCenter.hs | 50 ++++++++++++++++++++++++++++++++++++- src/Handler/SAP.hs | 2 +- src/Jobs/Handler/LMS.hs | 4 +-- src/Utils/Print.hs | 24 ++++++++++++------ 10 files changed, 84 insertions(+), 21 deletions(-) diff --git a/models/audit.model b/models/audit.model index fd0889392..6a1277b7a 100644 --- a/models/audit.model +++ b/models/audit.model @@ -14,9 +14,10 @@ TransactionLog InterfaceLog interface Text subtype Text - write Bool -- requestMethod /= GET, i.e. True implies a write to FRADrive + write Bool -- requestMethod /= GET, i.e. True implies a write to FRADrive time UTCTime - rows Int Maybe -- number of datasets transmitted - info Text -- addtional status information + rows Int Maybe -- number of datasets transmitted + info Text -- addtional status information + success Bool default=true -- false logs a failure; but it will be overwritten by next transaction, but logged in TransactionLog UniqueInterfaceSubtypeWrite interface subtype write deriving Eq Read Show Generic \ No newline at end of file diff --git a/src/Audit.hs b/src/Audit.hs index e13c769b9..0e93fc9e7 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -123,11 +123,12 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User ) => Text -- ^ Interface that is used -> Text -- ^ Subtype of the interface, if any + -> Bool -- ^ Success=True, Failure=False -> Maybe Int -- ^ Number of transmitted datasets -> Text -- ^ Any additional information -> ReaderT (YesodPersistBackend (HandlerSite m)) m () -- ^ Log a transaction using information available from `HandlerT`, also calls `audit` -logInterface interfaceLogInterface interfaceLogSubtype interfaceLogRows interfaceLogInfo = do +logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do interfaceLogTime <- liftIO getCurrentTime interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest @@ -138,4 +139,5 @@ logInterface interfaceLogInterface interfaceLogSubtype interfaceLogRows interfac , transactionInterfaceWrite = interfaceLogWrite , transactionInterfaceRows = interfaceLogRows , transactionInterfaceInfo = interfaceLogInfo + , transactionInterfaceSuccess = Just interfaceLogSuccess } diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index b7ebe8807..976171ec4 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -240,6 +240,7 @@ data Transaction , transactionInterfaceWrite :: Bool -- True implies a write to FRADrive , transactionInterfaceRows :: Maybe Int , transactionInterfaceInfo :: Text + , transactionInterfaceSuccess :: Maybe Bool -- Just False implies a failure; Maybe used to achieve backwards compatibility } deriving (Eq, Ord, Read, Show, Generic) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 2b9f17857..fbaf5df6e 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -257,8 +257,8 @@ mkInterfaceLogTable flagError cutOffOldTime = do mkBadInfo _ _ = return mempty writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True) - (InterfaceLog "AVS" "Synch" True okTime okRows badInfo) - [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo] + (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):_) -> @@ -287,8 +287,8 @@ mkInterfaceLogTable flagError cutOffOldTime = do , 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 i - InterfaceLog _ _ _ _ _ i -> textCell i + InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt i + InterfaceLog _ _ _ _ _ i _ -> textCell i ] dbtSorting = mconcat [ singletonMap "interface" $ SortColumn (E.^. InterfaceLogInterface) diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 3e4b00b24..1b149b95f 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -213,6 +213,6 @@ getLmsLearnersDirectR sid qsh = do $logInfoS "LMS" msg addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered - <* runDB (logInterface "LMS" (ciOriginal qsh) (Just nr) "") + <* runDB (logInterface "LMS" (ciOriginal qsh) True (Just nr) "") -- 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 201c2eab4..a0a6fefb6 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -315,12 +315,13 @@ postLmsReportDirectR sid qsh = do case enr of Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e + logInterface "LMS" (ciOriginal qsh) False Nothing "" return (badRequest400, "Exception: " <> tshow e) Right nr -> 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) (Just nr) "" + logInterface "LMS" (ciOriginal qsh) True (Just nr) "" return (ok200, msg) [] -> do let msg = "Report upload file missing." diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 6be31bf20..3fdd24b35 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -11,6 +11,7 @@ module Handler.PrintCenter , getPrintSendR , postPrintSendR , getPrintAckR , postPrintAckR , postPrintAckDirectR + , getPrintLogR ) where import Import @@ -26,7 +27,7 @@ import Database.Esqueleto.Utils.TH import Utils.Print --- import Data.Aeson (encode) +import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text -- import qualified Data.Set as Set @@ -471,3 +472,50 @@ postPrintAckDirectR = do $logErrorS "APC" msg return (badRequest400, msg) sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back + + +getPrintLogR :: Handler Html +getPrintLogR = do + let + logDBTable = DBTable{..} + where + resultLog :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) TransactionLog + resultLog = _dbrOutput . _1 + + resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction) + resultTrans = _dbrOutput . _2 + + dbtIdent = "lpr-log" :: Text + dbtSQLQuery l = do + E.where_ $ E.val "LPR" E.==. l E.^. TransactionLogInfo E.->>. "interface-name" + return l + dbtRowKey = (E.^. TransactionLogId) + dbtProj = dbtProjSimple $ \(Entity _ l) -> do + return (l, Aeson.fromJSON $ transactionLogInfo l) + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t + , sortable Nothing (textCell "Status") $ \(view resultTrans -> jt) -> + case jt of + (Aeson.Error _) -> mempty + (Aeson.Success t) -> cellMaybe iconBoolCell $ transactionInterfaceSuccess t + , sortable Nothing (i18nCell MsgSystemMessageContent) $ \(view resultTrans -> jt) -> + case jt of + (Aeson.Error msg) -> stringCell msg + (Aeson.Success t) -> textCell $ transactionInterfaceInfo t + ] + dbtSorting = mconcat + [ singletonMap "time" $ SortColumn (E.^. TransactionLogTime) + ] + dbtFilter = mempty + dbtFilterUI = mempty + + dbtStyle = def + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + validator = def & defaultSorting [ SortDescBy "time" ] + tbl <- runDB $ dbTableDB' validator logDBTable + siteLayoutMsg MsgMenuApc $ do + setTitleI MsgMenuApc + [whamlet|^{tbl}|] diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 4fb8c2c5d..3414b618b 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -141,7 +141,7 @@ getQualificationSAPDirectR = do msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" quals = Text.intercalate ", " $ nubOrd $ mapMaybe (view (_2 . E._unValue)) qualUsers $logInfoS "SAP" msg - let logInt = runDB $ logInterface "SAP" quals (Just nr) "" + let logInt = runDB $ logInterface "SAP" quals True (Just nr) "" addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 763f46b39..12ab943f2 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -117,7 +117,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } } forM_ renewalUsers (queueDBJob . usr_job) - logInterface "LMS" (qshort <> "-enq") (Just $ length renewalUsers) "" + logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) "" dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act @@ -259,7 +259,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ] - logInterface "LMS" (qshort <> "-deq") (Just nrBlocked) (tshow nrExpired <> " expired") + logInterface "LMS" (qshort <> "-deq") True (Just nrBlocked) (tshow nrExpired <> " expired") dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 7735f1f09..8687158b8 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -269,13 +269,17 @@ printLetter' pji pdf = do -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing + qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get + let logInter = flip (logInterface "LPR" qshort) (Just 1) lprPDF printJobFilename pdf >>= \case Left err -> do + logInter False err return $ Left err Right ok -> do printJobCreated <- liftIO getCurrentTime -- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows - insert_ PrintJob {..} + insert_ PrintJob{..} + logInter True ok return $ Right (ok, printJobFilename) reprintPDF :: Bool -> PrintJobId -> DB (Either Text Text) @@ -283,13 +287,19 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown." where reprint :: PrintJob -> DB (Either Text Text) reprint pj@PrintJob{..} = do + qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get + let logInter = flip (logInterface "LPR" qshort) (Just 1) result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile - whenIsRight result $ const $ do - now <- liftIO getCurrentTime - insert_ pj{ printJobAcknowledged = Nothing - , printJobCreated = now - -- , printJobApcIdent = ??? cannot be modified here, since it is included inside the PDF - } + case result of + Left err -> + logInter False err + Right m -> do + logInter True m + now <- liftIO getCurrentTime + insert_ pj{ printJobAcknowledged = Nothing + , printJobCreated = now + -- , printJobApcIdent = ??? cannot be modified here, since it is included inside the PDF + } return result {-