reverse order of logs in jobLog (fixes #192)

src/Gargantext/API/Admin/EnvTypes.hs

@@ -18,11 +18,11 @@ module Gargantext.API.Admin.EnvTypes (
   , ConcreteJobHandle -- opaque
   ) where
 
-import Control.Lens hiding ((:>))
+import Control.Lens hiding ((:<))
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Pool (Pool)
-import Data.Sequence (Seq, ViewR(..), viewr)
+import Data.Sequence (Seq, ViewL(..), viewl)
 import Database.PostgreSQL.Simple (Connection)
 import GHC.Generics (Generic)
 import Network.HTTP.Client (Manager)
@@ -159,12 +159,12 @@ instance Jobs.MonadJobStatus (GargM Env err) where
       Just j  -> case jTask j of
         QueuedJ _   -> pure noJobLog
         RunningJ rj -> liftIO (rjGetLog rj) <&>
-                         \lgs -> case viewr lgs of
-                                   EmptyR -> noJobLog
-                                   _ :> l -> l
-        DoneJ lgs _ -> pure $ case viewr lgs of
-                                   EmptyR -> noJobLog
-                                   _ :> l -> l
+                         \lgs -> case viewl lgs of
+                                   EmptyL -> noJobLog
+                                   l :< _ -> l
+        DoneJ lgs _ -> pure $ case viewl lgs of
+                                   EmptyL -> noJobLog
+                                   l :< _ -> l
 
   withTracer extraLogger (JobHandle jId logger) n = n (JobHandle jId (\w -> logger w >> liftIO (extraLogger w)))
 

src/Gargantext/API/Node/Corpus/New.hs

@@ -20,6 +20,7 @@ module Gargantext.API.Node.Corpus.New
 
 import Conduit
 import Control.Lens hiding (elements, Empty)
+import Control.Monad
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import qualified Data.ByteString.Base64 as BSB64
@@ -193,7 +194,6 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
                                          , _wq_lang = l
                                          , _wq_flowListWith = flw }) maybeLimit jobHandle = do
   -- TODO ...
-  markStarted 3 jobHandle
   -- printDebug "[addToCorpusWithQuery] (cid, dbs)" (cid, dbs)
   -- printDebug "[addToCorpusWithQuery] datafield" datafield
   -- printDebug "[addToCorpusWithQuery] flowListWith" flw
@@ -202,49 +202,40 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
     Just Web -> do
       -- printDebug "[addToCorpusWithQuery] processing web request" datafield
 
+      markStarted 1 jobHandle
+
       _ <- triggerSearxSearch user cid q l jobHandle
 
       markComplete jobHandle
 
     _ -> do
+      markStarted 3 jobHandle
+
       -- TODO add cid
       -- TODO if cid is folder -> create Corpus
       --      if cid is corpus -> add to corpus
       --      if cid is root   -> create corpus in Private
       -- printDebug "[G.A.N.C.New] getDataText with query" q
-      databaseOrigin <- database2origin dbs
-      eTxts <- mapM (\db -> getDataText db (Multi l) q maybeLimit) [databaseOrigin]
+      db   <- database2origin dbs
+      eTxt <- getDataText db (Multi l) q maybeLimit
 
-      let lTxts = lefts eTxts
       -- printDebug "[G.A.N.C.New] lTxts" lTxts
-      case lTxts of
-        [] -> do
-          let txts = rights eTxts
+      case eTxt of
+        Right txt -> do
           -- TODO Sum lenghts of each txt elements
 
-          -- NOTE(adinapoli) Some other weird arithmetic to have the
-          -- following 'JobLog' as output:
-          -- JobLog
-          -- { _scst_succeeded = Just 2
-          -- , _scst_failed    = Just 0
-          -- , _scst_remaining = Just $ 1 + length txts
-          -- , _scst_events    = Just []
-          -- }
-
-          markStarted (3 + length txts) jobHandle
-          markProgress 2 jobHandle
+          markProgress 1 jobHandle
 
-          _cids <- mapM (\txt -> do
-                           flowDataText user txt (Multi l) cid (Just flw) jobHandle) txts
+          void $ flowDataText user txt (Multi l) cid (Just flw) jobHandle
           -- printDebug "corpus id" cids
           -- printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
           sendMail user
           -- TODO ...
           markComplete jobHandle
 
-        (err:_) -> do
+        Left err -> do
           -- printDebug "Error: " err
-          markFailure 1 (Just $ T.pack (show err)) jobHandle
+          markFailed (Just $ T.pack (show err)) jobHandle
 
 type AddWithForm = Summary "Add with FormUrlEncoded to corpus endpoint"
    :> "corpus"

src/Gargantext/Utils/Jobs/Internal.hs

@@ -118,6 +118,15 @@ pollJob limit offset jid je = do
       let st = either (const SJ.IsFailure) (const SJ.IsFinished) r
           me = either (Just . T.pack . show) (const Nothing) r
       in pure (ls, st, me)
+  -- /NOTE/: We need to be careful with the ordering of the logs here:
+  -- we want to return the logs ordered from the newest to the oldest,
+  -- because the API will use 'limit' to show only the newest ones,
+  -- taking 'limit' of them from the front of the list.
+  --
+  -- Due to the fact we do not force any 'Ord' constraint on an 'event' type,
+  -- and it would be inefficient to reverse the list here, it's important
+  -- that the concrete implementation of 'rjGetLog' returns the logs in the
+  -- correct order.
   pure $ SJ.jobStatus jid limit offset (toList logs) status merr
 
 waitJob
@@ -176,4 +185,5 @@ killJob t limit offset jid je = do
           me = either (Just . T.pack . show) (const Nothing) r
       removeJob False t jid
       pure (lgs, st, me)
+  -- /NOTE/: Same proviso as in 'pollJob' applies here.
   pure $ SJ.jobStatus jid limit offset (toList logs) status merr

src/Gargantext/Utils/Jobs/Map.hs

@@ -13,7 +13,6 @@ module Gargantext.Utils.Jobs.Map (
   , newJobMap
   , lookupJob
   , gcThread
-  , jobLog
   , addJobEntry
   , deleteJob
   , runJob
@@ -117,8 +116,10 @@ gcThread js (JobMap mvar) = go
           _      -> False
 
 -- | Make a 'Logger' that 'mappend's monoidal values in a 'TVar'.
+-- /IMPORTANT/: The new value is appended in front. The ordering is important later on
+-- when consuming logs from the API (see for example 'pollJob').
 jobLog :: Semigroup w => TVar w -> Logger w -- w -> IO ()
-jobLog logvar = \w -> atomically $ modifyTVar' logvar (\old_w -> old_w <> w)
+jobLog logvar = \w -> atomically $ modifyTVar' logvar (\old_w -> w <> old_w)
 
 -- | Generating new 'JobEntry's.
 addJobEntry