Merge branch '495-dev-job-progress-fix-mark-started' into 'dev'

Resolve "[Server slowness] With the dev branch on the dev instance, we're experiencing a real slowness" (JobInfo changes)

See merge request !429

gargantext.cabal

@@ -753,6 +753,7 @@ common commonTestDependencies
     , generic-arbitrary >= 1.0.1 && < 2
     , graphviz ^>= 2999.20.1.0
     , haskell-bee
+    , haskell-bee-pgmq
     , hspec ^>= 2.11.1
     , hspec-expectations >= 0.8 && < 0.9
     , hspec-expectations-lifted < 0.11

src/Gargantext/API/Job.hs

@@ -23,7 +23,7 @@ module Gargantext.API.Job (
   , addWarningEvent
   ) where
 
-import Control.Lens (over, _Just)
+import Control.Lens ((%~), over, _Just)
 import Data.Text qualified as T
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.Prelude
@@ -66,7 +66,12 @@ jobLogComplete jl =
         & over scst_remaining (const (Just 0))
 
 jobLogAddMore :: Int -> JobLog -> JobLog
-jobLogAddMore moreSteps jl = jl & over (scst_remaining . _Just) (+ moreSteps)
+jobLogAddMore moreSteps jl =
+  jl & scst_remaining %~ (maybe (Just 0) Just)
+     & scst_succeeded %~ (maybe (Just 0) Just)
+     & scst_failed %~ (maybe (Just 0) Just)
+     & scst_events %~ (maybe (Just []) Just)
+     & (scst_remaining . _Just) %~ (+ moreSteps)
 
 jobLogFailures :: Int -> JobLog -> JobLog
 jobLogFailures n jl = over (scst_failed . _Just) (+ n) $

src/Gargantext/Core/Worker/Env.hs

@@ -9,8 +9,9 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TemplateHaskell      #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans      #-}  -- orphan HasNodeError BackendInternalError
 
@@ -25,6 +26,7 @@ import Control.Lens.TH
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Maybe (fromJust)
 import Data.Pool qualified as Pool
+import Data.Text qualified as T
 import Database.PostgreSQL.Simple qualified as PSQL
 import Gargantext.API.Admin.Orchestrator.Types (JobLog, noJobLog)
 import Gargantext.API.Errors (BackendInternalError)
@@ -42,7 +44,7 @@ import Gargantext.Core.Notifications.CentralExchange.Types qualified as CET
 import Gargantext.Core.Worker.Types (JobInfo(..))
 import Gargantext.Database.Prelude (HasConnectionPool(..))
 import Gargantext.Prelude hiding (to)
-import Gargantext.System.Logging (HasLogger(..), Logger, LogLevel(..), MonadLogger(..), withLogger, logMsg, withLoggerIO)
+import Gargantext.System.Logging (HasLogger(..), Logger, LogLevel(..), MonadLogger(..), withLogger, logMsg, logLocM, withLoggerIO)
 import Gargantext.System.Logging.Loggers
 import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
 import System.Log.FastLogger qualified as FL
@@ -182,9 +184,21 @@ instance MonadJobStatus WorkerMonad where
   type JobEventType   WorkerMonad = JobLog
 
   noJobHandle Proxy     = WorkerNoJobHandle
-  getLatestJobStatus _  = WorkerMonad (pure noJobLog)
+  getLatestJobStatus WorkerNoJobHandle    = pure noJobLog
+  getLatestJobStatus (WorkerJobHandle ji) = do
+    stateTVar <- asks _w_env_job_state
+    state' <- liftIO $ readTVarIO stateTVar
+    pure $ case state' of
+      Nothing -> noJobLog
+      Just wjs ->
+        if _wjs_job_info wjs == ji
+        then
+          _wjs_job_log wjs
+        else
+          noJobLog
   withTracer _ jh n     = n jh
-  markStarted n jh      = updateJobProgress jh (const $ jobLogStart $ RemainingSteps n)
+  markStarted n jh      =
+    updateJobProgress jh (const $ jobLogStart $ RemainingSteps n)
   markProgress steps jh = updateJobProgress jh (jobLogProgress steps)
   markFailure steps mb_msg jh =
     updateJobProgress jh (\latest -> case mb_msg of
@@ -208,7 +222,9 @@ updateJobProgress (WorkerJobHandle (ji@JobInfo { _ji_message_id })) f = do
   case state' of
     Nothing -> pure ()
     Just wjs -> do
-      CET.ce_notify $ CET.UpdateWorkerProgress ji (_wjs_job_log wjs)
+      (CET.ce_notify $ CET.UpdateWorkerProgress ji (_wjs_job_log wjs))
+      `CES.catch` (\(e :: SomeException) ->
+                     $(logLocM) WARNING $ T.pack $ displayException e)
   where
     updateState mwjs =
       let initJobLog =

src/Gargantext/Core/Worker/Types.hs

-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
 {-|
 Module      : Gargantext.Core.Worker.Types
 Description : Some useful worker types