chore(lpr): error log as interface log

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  
+  rows      Int Maybe             -- number of datasets transmitted  
-  info      Text        -- addtional status information  
+  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

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
     }

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)
 

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)
+        (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo))
-        [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. 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 "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt i
-              InterfaceLog _     _       _    _ _ i -> textCell i 
+              InterfaceLog _     _       _    _ _ i _ -> textCell i 
           ]
         dbtSorting = mconcat
           [ singletonMap "interface" $ SortColumn (E.^. InterfaceLogInterface)

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

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

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

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
   

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

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 
+      case result of
-        now <- liftIO getCurrentTime        
+        Left err -> 
-        insert_ pj{ printJobAcknowledged  = Nothing
+          logInter False err
-                  , printJobCreated       = now
+        Right m -> do
-                  -- , printJobApcIdent      = ??? cannot be modified here, since it is included inside the PDF
+          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
 
 {-