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

chore(lpr): error log as interface log

Browse Source
This commit is contained in:
Steffen Jost 2024-01-30 18:42:13 +01:00
parent d1fce58ec2
commit fd388b91f4
10 changed files with 84 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
models/audit.model
View File

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

4
src/Audit.hs
View File

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

1
src/Audit/Types.hs
View File

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

8
src/Handler/Admin.hs
View File

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

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

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

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

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

50
src/Handler/PrintCenter.hs
View File

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

2
src/Handler/SAP.hs
View File

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

4
src/Jobs/Handler/LMS.hs
View File

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

24
src/Utils/Print.hs
View File

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