refactor(log): simplify interface logging

Since each interface log also triggers an AuditLog entry, the additional data about user and instance do not need to be saved twice

models/audit.model

@@ -12,13 +12,11 @@ TransactionLog
   deriving Eq Read Show Generic
 
 InterfaceLog  
-  time UTCTime
-  instance InstanceId
-  initiator UserId Maybe -- User associated with performing this interface access
-  remote IP Maybe -- Remote party that triggered this action via HTTP
   interface Text
   subtype   Text
-  info      Text
+  write     Bool        -- requestMethod /= GET, i.e. True implies a write to FRADrive
-  write     Bool  -- True implies a write to FRADrive
+  time      UTCTime
+  rows      Int Maybe   -- number of datasets transmitted  
+  info      Text        -- addtional status information  
   UniqueInterfaceSubtypeWrite interface subtype write
   deriving Eq Read Show Generic

src/Audit.hs

@@ -108,17 +108,7 @@ audit transaction@(toJSON -> transactionLogInfo) = do
   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
@@ -131,33 +121,21 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User
          , HasAppSettings (HandlerSite m)
          , HasCallStack
          )
-      => Text -- ^ Interface that is used
+      => Text       -- ^ Interface that is used
-      -> Text -- ^ Subtype of the interface, if any      
+      -> Text       -- ^ Subtype of the interface, if any
-      -> Text -- ^ Any additional information
+      -> Maybe Int  -- ^ Number of transmitted datasets
+      -> Text       -- ^ Any additional information
       -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
--- ^ Log a transaction using information available from `HandlerT`:
+-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
---
+logInterface interfaceLogInterface interfaceLogSubtype interfaceLogRows interfaceLogInfo = do
---   - `transactionLogTime` is now
+  interfaceLogTime  <- liftIO getCurrentTime
---   - `transactionLogInitiator` is currently logged in user (or none)
---   - `transactionLogRemote` is determined from current HTTP-Request
-logInterface interfaceLogInterface interfaceLogSubtype interfaceLogInfo = do
-  interfaceLogTime <- liftIO getCurrentTime
-  interfaceLogInstance <- getsYesod $ view instanceID
-  interfaceLogInitiator <- liftHandler maybeAuthId
-  interfaceLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
   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
+  audit TransactionInterface
-          { transactionInterfaceName    = interfaceLogInterface
+    { transactionInterfaceName    = interfaceLogInterface
-          , transactionInterfaceSubtype = interfaceLogSubtype
+    , transactionInterfaceSubtype = interfaceLogSubtype
-          , transactionInterfaceInfo    = interfaceLogInfo
+    , transactionInterfaceWrite   = interfaceLogWrite
-          , transactionInterfaceWrite   = interfaceLogWrite
+    , transactionInterfaceRows    = interfaceLogRows
-          }
+    , transactionInterfaceInfo    = interfaceLogInfo
-  auditHelper transaction TransactionLog 
+    }
-          { transactionLogTime      = interfaceLogTime
-          , transactionLogInstance  = interfaceLogInstance
-          , transactionLogInitiator = interfaceLogInitiator
-          , transactionLogRemote    = interfaceLogRemote
-          , transactionLogInfo      = toJSON transaction
-          }

src/Audit/Types.hs

@@ -237,8 +237,9 @@ data Transaction
   | TransactionInterface
     { transactionInterfaceName                :: Text
     , transactionInterfaceSubtype             :: Text
-    , transactionInterfaceInfo                :: Text
     , transactionInterfaceWrite               :: Bool                 -- True implies a write to FRADrive
+    , transactionInterfaceRows                :: Maybe Int
+    , transactionInterfaceInfo                :: Text
     }
   deriving (Eq, Ord, Read, Show, Generic)
 

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) (tshow nr <> " rows"))
+    <* runDB (logInterface "LMS" (ciOriginal qsh) (Just nr) "")
 -- direct Download see:
 -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

src/Handler/LMS/Report.hs

@@ -200,7 +200,6 @@ mkReportTable sid qsh qid = do
                   , LmsReportLock             =. lmsReportCsvLock   actionData
                   , LmsReportTimestamp        =. eanow
                   ]                
-                -- audit $ Transaction.. (add to Audit.Types)
             lift . queueDBJob $ JobLmsReports qid
             return $ LmsReportR sid qsh
           , dbtCsvRenderKey           = const $ \case
@@ -321,7 +320,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")
+            logInterface "LMS" (ciOriginal qsh) (Just nr) ""
             return (ok200, msg)
     []     -> do
       let msg = "Report upload file missing."

src/Handler/SAP.hs

@@ -16,6 +16,7 @@ import Handler.Utils
 import Handler.Utils.Csv
 import Handler.Utils.Profile
 
+import qualified Data.Text as Text (intercalate)
 -- import qualified Data.CaseInsensitive as CI
 import qualified Data.Csv as Csv
 import           Database.Esqueleto.Experimental ((:&)(..))
@@ -138,8 +139,9 @@ getQualificationSAPDirectR = do
       csvSheetName = "fradrive_sap_" <> fdate <> ".csv"
       nr  = length qualUsers
       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" "" $ tshow nr <> " rows"
+  let logInt = runDB $ logInterface "SAP" quals (Just nr) ""
   addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
   csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt