Merge remote-tracking branch 'origin/adinapoli/issue-258-part-2' into dev

bin/gargantext-server/Main.hs

@@ -16,15 +16,19 @@ Script to start gargantext with different modes (Dev, Prod, Mock).
 {-# LANGUAGE Strict               #-}
 {-# LANGUAGE TypeOperators        #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TypeFamilies #-}
 
 
 module Main where
 
 
+import Data.String (String)
 import Data.Text (unpack)
 import Data.Version (showVersion)
-import Gargantext.API (startGargantext, Mode(..)) -- , startGargantextMock)
+import Gargantext.API (startGargantext) -- , startGargantextMock)
+import Gargantext.API.Admin.EnvTypes
 import Gargantext.Prelude
+import Gargantext.System.Logging
 import Options.Generic
 import System.Exit (exitSuccess)
 import qualified Paths_gargantext as PG -- cabal magic build module
@@ -49,14 +53,26 @@ data MyOptions w =
 instance ParseRecord (MyOptions Wrapped)
 deriving instance Show (MyOptions Unwrapped)
 
+-- | A plain logger in the IO monad, waiting for more serious logging solutions like
+-- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229
+instance HasLogger IO where
+  data instance Logger IO        = IOLogger
+  type instance LogInitParams IO = ()
+  type instance LogPayload IO    = String
+  initLogger                     = \() -> pure IOLogger
+  destroyLogger                  = \_  -> pure ()
+  logMsg = \IOLogger lvl msg ->
+    let pfx = "[" <> show lvl <> "] "
+    in putStrLn $ pfx <> msg
+  logTxt lgr lvl msg = logMsg lgr lvl (unpack msg)
 
 main :: IO ()
-main = do
+main = withLogger () $ \ioLogger -> do
   MyOptions myMode myPort myIniFile myVersion  <- unwrapRecord
           "Gargantext server"
   ---------------------------------------------------------------
   if myVersion then do
-    putStrLn $ "Version: " <> showVersion PG.version
+    logMsg ioLogger INFO $ "Version: " <> showVersion PG.version
     System.Exit.exitSuccess
   else
     return ()
@@ -73,6 +89,6 @@ main = do
   let start = case myMode of
         Mock -> panic "[ERROR] Mock mode unsupported"
         _ -> startGargantext myMode myPort' (unpack myIniFile')
-  putStrLn $ "Starting with " <> show myMode <> " mode."
+  logMsg ioLogger INFO $ "Starting with " <> show myMode <> " mode."
   start
   ---------------------------------------------------------------

cabal.project

@@ -79,7 +79,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://gitlab.iscpif.fr/gargantext/crawlers/arxiv-api.git
-    tag: 2d7e5753cbbce248b860b571a0e9885415c846f7
+    tag: eb130c71fa17adaceed6ff66beefbccb13df51ba
 
 source-repository-package
     type: git

gargantext.cabal

@@ -117,6 +117,7 @@ library
       Gargantext.Database.Query.Table.Node.UpdateOpaleye
       Gargantext.Database.Query.Table.User
       Gargantext.Database.Schema.Ngrams
+      Gargantext.System.Logging
       Gargantext.Defaults
       Gargantext.Utils.Jobs
       Gargantext.Utils.Jobs.Internal

src/Gargantext/API.hs

@@ -29,13 +29,14 @@ Pouillard (who mainly made it).
 {-# LANGUAGE BangPatterns         #-}
 {-# LANGUAGE NumericUnderscores   #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
 module Gargantext.API
       where
 
 import Control.Concurrent
 import Control.Exception (catch, finally, SomeException{-, displayException, IOException-})
-import Control.Lens
+import Control.Lens hiding (Level)
 import Control.Monad.Except
 import Control.Monad.Reader (runReaderT)
 import Data.Either
@@ -46,9 +47,8 @@ import Data.Text.Encoding (encodeUtf8)
 import Data.Text.IO (putStrLn)
 import Data.Validity
 import GHC.Base (Applicative)
-import GHC.Generics (Generic)
 import Gargantext.API.Admin.Auth.Types (AuthContext)
-import Gargantext.API.Admin.EnvTypes (Env)
+import Gargantext.API.Admin.EnvTypes (Env, Mode(..))
 import Gargantext.API.Admin.Settings (newEnv)
 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
 import Gargantext.API.EKG
@@ -69,14 +69,12 @@ import Servant
 import System.FilePath
 import qualified Gargantext.Database.Prelude as DB
 import qualified System.Cron.Schedule as Cron
-
-data Mode = Dev | Mock | Prod
-  deriving (Show, Read, Generic)
+import Gargantext.System.Logging
 
 -- | startGargantext takes as parameters port number and Ini file.
 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
-startGargantext mode port file = do
-  env <- newEnv port file
+startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
+  env <- newEnv logger port file
   runDbCheck env
   portRouteInfo port
   app <- makeApp env

src/Gargantext/API/Admin/EnvTypes.hs

@@ -2,15 +2,18 @@
 
 {-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Gargantext.API.Admin.EnvTypes (
     GargJob(..)
   , Env(..)
+  , Mode(..)
   , mkJobHandle
   , env_logger
   , env_manager
   , env_self_url
   , menv_firewall
+  , dev_env_logger
 
   , MockEnv(..)
   , DevEnv(..)
@@ -18,7 +21,7 @@ module Gargantext.API.Admin.EnvTypes (
   , ConcreteJobHandle -- opaque
   ) where
 
-import Control.Lens hiding ((:<))
+import Control.Lens hiding (Level, (:<))
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Pool (Pool)
@@ -29,24 +32,62 @@ import Network.HTTP.Client (Manager)
 import Servant.Client (BaseUrl)
 import Servant.Job.Async (HasJobEnv(..), Job)
 import qualified Servant.Job.Async as SJ
-import System.Log.FastLogger
 import qualified Servant.Job.Core
 
-import Gargantext.API.Admin.Types
+import Data.List ((\\))
+import qualified Data.Text as T
 import Gargantext.API.Admin.Orchestrator.Types
+import Gargantext.API.Admin.Types
 import Gargantext.API.Job
-import Gargantext.API.Prelude (GargM)
-import Gargantext.Core.NodeStory
+import Gargantext.API.Prelude (GargM, GargError)
 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
 import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
+import Gargantext.Core.NodeStory
 import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(..))
 import Gargantext.Prelude.Mail.Types (MailConfig)
+import Gargantext.System.Logging
+import qualified System.Log.FastLogger as FL
 
 import qualified Gargantext.Utils.Jobs.Monad as Jobs
 import Gargantext.Utils.Jobs.Map (LoggerM, J(..), jTask, rjGetLog)
 
+data Mode = Dev | Mock | Prod
+  deriving (Show, Read, Generic)
+
+-- | Given the 'Mode' the server is running in, it returns the list of
+-- allowed levels. For example for production we ignore everything which
+-- has priority lower than "warning".
+modeToLoggingLevels :: Mode -> [LogLevel]
+modeToLoggingLevels = \case
+   Dev  -> [minBound .. maxBound]
+   Mock -> [minBound .. maxBound]
+   -- For production, accepts everything but DEBUG.
+   Prod -> [minBound .. maxBound] \\ [DEBUG]
+
+instance MonadLogger (GargM Env GargError) where
+  getLogger = asks _env_logger
+
+instance HasLogger (GargM Env GargError) where
+  data instance Logger (GargM Env GargError)  =
+    GargLogger {
+        logger_mode    :: Mode
+      , logger_set     :: FL.LoggerSet
+      }
+  type instance LogInitParams (GargM Env GargError) = Mode
+  type instance LogPayload (GargM Env GargError)    = FL.LogStr
+  initLogger                = \mode -> do
+    logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
+    pure $ GargLogger mode logger_set
+  destroyLogger             = \GargLogger{..}  -> liftIO $ FL.rmLoggerSet logger_set
+  logMsg = \(GargLogger mode logger_set) lvl msg -> do
+    let pfx = "[" <> show lvl <> "] "
+    when (lvl `elem` (modeToLoggingLevels mode)) $
+      liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
+  logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)
+
+
 data GargJob
   = TableNgramsJob
   | ForgotPasswordJob
@@ -72,7 +113,7 @@ data GargJob
 -- we need to remember to force the fields to WHNF at that point.
 data Env = Env
   { _env_settings  :: ~Settings
-  , _env_logger    :: ~LoggerSet
+  , _env_logger    :: ~(Logger (GargM Env GargError))
   , _env_pool      :: ~(Pool Connection)
   , _env_nodeStory :: ~NodeStoryEnv
   , _env_manager   :: ~Manager
@@ -186,6 +227,8 @@ instance Jobs.MonadJobStatus (GargM Env err) where
                                        Just msg -> jobLogFailTotalWithMessage msg latest
                          )
 
+  addMoreSteps steps jh = updateJobProgress jh (jobLogAddMore steps)
+
 data MockEnv = MockEnv
   { _menv_firewall :: !FireWall
   }
@@ -193,9 +236,31 @@ data MockEnv = MockEnv
 
 makeLenses ''MockEnv
 
+instance MonadLogger (GargM DevEnv GargError) where
+  getLogger = asks _dev_env_logger
+
+instance HasLogger (GargM DevEnv GargError) where
+  data instance Logger (GargM DevEnv GargError)  =
+    GargDevLogger {
+        dev_logger_mode    :: Mode
+      , dev_logger_set     :: FL.LoggerSet
+      }
+  type instance LogInitParams (GargM DevEnv GargError) = Mode
+  type instance LogPayload (GargM DevEnv GargError)    = FL.LogStr
+  initLogger                = \mode -> do
+    dev_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
+    pure $ GargDevLogger mode dev_logger_set
+  destroyLogger             = \GargDevLogger{..}  -> liftIO $ FL.rmLoggerSet dev_logger_set
+  logMsg = \(GargDevLogger mode logger_set) lvl msg -> do
+    let pfx = "[" <> show lvl <> "] "
+    when (lvl `elem` (modeToLoggingLevels mode)) $
+      liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
+  logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)
+
 data DevEnv = DevEnv
   { _dev_env_settings  :: !Settings
   , _dev_env_config    :: !GargConfig
+  , _dev_env_logger    :: !(Logger (GargM DevEnv GargError))
   , _dev_env_pool      :: !(Pool Connection)
   , _dev_env_nodeStory :: !NodeStoryEnv
   , _dev_env_mail      :: !MailConfig
@@ -229,6 +294,8 @@ instance Jobs.MonadJobStatus (GargM DevEnv err) where
 
   markFailed _ _ = pure ()
 
+  addMoreSteps _ _ = pure ()
+
 instance HasConfig DevEnv where
   hasConfig = dev_env_config
 

src/Gargantext/API/Admin/Settings.hs

@@ -37,12 +37,12 @@ import System.Directory
 -- import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
 import System.IO (FilePath, hClose)
 import System.IO.Temp (withTempFile)
-import System.Log.FastLogger
 import qualified Data.ByteString.Lazy as L
 
 
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Types
+import Gargantext.API.Prelude
 -- import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
 import Gargantext.Core.NLP (nlpServerMap)
 import Gargantext.Database.Prelude (databaseParameters, hasConfig)
@@ -54,6 +54,7 @@ import qualified Gargantext.Utils.Jobs       as Jobs
 import qualified Gargantext.Utils.Jobs.Monad as Jobs
 import qualified Gargantext.Utils.Jobs.Queue as Jobs
 import qualified Gargantext.Utils.Jobs.Settings as Jobs
+import Gargantext.System.Logging
 
 devSettings :: FilePath -> IO Settings
 devSettings jwkFile = do
@@ -176,8 +177,8 @@ readRepoEnv repoDir = do
 devJwkFile :: FilePath
 devJwkFile = "dev.jwk"
 
-newEnv :: PortNumber -> FilePath -> IO Env
-newEnv port file = do
+newEnv :: Logger (GargM Env GargError) -> PortNumber -> FilePath -> IO Env
+newEnv logger port file = do
   !manager_env  <- newTlsManager
   !settings'    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
   when (port /= settings' ^. appPort) $
@@ -200,7 +201,6 @@ newEnv port file = do
                         & Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_job_timeout)
                         & Jobs.l_jsIDTimeout  .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_id_timeout)
   !jobs_env     <- Jobs.newJobEnv jobs_settings prios' manager_env
-  !logger        <- newStderrLoggerSet defaultBufSize
   !config_mail  <- Mail.readConfig file
   !nlp_env      <- nlpServerMap <$> NLP.readConfig file
 

src/Gargantext/API/Dev.hs

@@ -29,16 +29,17 @@ import qualified Gargantext.Prelude.Mail as Mail
 import qualified Gargantext.Prelude.NLP as NLP
 import Servant
 import System.IO (FilePath)
+import Gargantext.System.Logging
 
 type IniPath  = FilePath
 -------------------------------------------------------------------
 withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
-withDevEnv iniPath k = do
-  env <- newDevEnv
+withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do
+  env <- newDevEnv logger
   k env -- `finally` cleanEnv env
 
   where
-    newDevEnv = do
+    newDevEnv logger = do
       cfg     <- readConfig         iniPath
       dbParam <- databaseParameters iniPath
       --nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
@@ -49,6 +50,7 @@ withDevEnv iniPath k = do
       nlp_config <- NLP.readConfig iniPath
       pure $ DevEnv
         { _dev_env_pool     = pool
+        , _dev_env_logger     = logger
         , _dev_env_nodeStory  = nodeStory_env
         , _dev_env_settings = setts
         , _dev_env_config   = cfg

src/Gargantext/API/Job.hs

@@ -31,7 +31,7 @@ addErrorEvent message = addEvent "ERROR" message
 
 jobLogProgress :: Int -> JobLog -> JobLog
 jobLogProgress n jl = over (scst_succeeded . _Just) (+ n) $
-                      over (scst_remaining . _Just) (\x -> x - n) jl
+                      over (scst_remaining . _Just) (\x -> max 0 (x - n)) jl
 
 -- | Mark a job as completely done, by adding the 'remaining' into 'succeeded'.
 -- At the end 'scst_remaining' will be 0, and 'scst_succeeded' will be 'oldvalue + remaining'.
@@ -41,6 +41,9 @@ jobLogComplete jl =
   in jl & over scst_succeeded (Just . maybe remainingNow ((+) remainingNow))
         & over scst_remaining (const (Just 0))
 
+jobLogAddMore :: Int -> JobLog -> JobLog
+jobLogAddMore moreSteps jl = jl & over (scst_remaining . _Just) (+ moreSteps)
+
 jobLogFailures :: Int -> JobLog -> JobLog
 jobLogFailures n jl = over (scst_failed . _Just) (+ n) $
                 over (scst_remaining . _Just) (\x -> x - n) jl

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

@@ -21,7 +21,6 @@ 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
@@ -67,6 +66,7 @@ import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
 import qualified Gargantext.Core.Text.Corpus.API as API
 import qualified Gargantext.Core.Text.Corpus.Parsers as Parser (FileType(..), parseFormatC)
 import qualified Gargantext.Database.GargDB as GargDB
+import Gargantext.System.Logging
 
 ------------------------------------------------------------------------
 {-
@@ -201,16 +201,17 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
                                          , _wq_datafield = datafield
                                          , _wq_lang = l
                                          , _wq_flowListWith = flw }) maybeLimit jobHandle = do
+
   -- TODO ...
-  -- printDebug "[addToCorpusWithQuery] (cid, dbs)" (cid, dbs)
-  -- printDebug "[addToCorpusWithQuery] datafield" datafield
-  -- printDebug "[addToCorpusWithQuery] flowListWith" flw
+  $(logLocM) DEBUG $ T.pack $ "(cid, dbs) " <> show (cid, dbs)
+  $(logLocM) DEBUG $ T.pack $ "datafield  " <> show datafield
+  $(logLocM) DEBUG $ T.pack $ "flowListWith " <> show flw
 
   addLanguageToCorpus cid l
 
   case datafield of
     Just Web -> do
-      -- printDebug "[addToCorpusWithQuery] processing web request" datafield
+      $(logLocM) DEBUG $ T.pack $ "processing web request " <> show datafield
 
       markStarted 1 jobHandle
 
@@ -225,7 +226,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
       -- 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
+      $(logLocM) DEBUG $ T.pack $ "getDataText with query: " <> show q
       let db = database2origin dbs
       mPubmedAPIKey <- getUserPubmedAPIKey user
       -- printDebug "[addToCorpusWithQuery] mPubmedAPIKey" mPubmedAPIKey
@@ -235,11 +236,11 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
       case eTxt of
         Right txt -> do
           -- TODO Sum lenghts of each txt elements
-
+          $(logLocM) DEBUG "Processing dataText results"
           markProgress 1 jobHandle
 
-          void $ flowDataText user txt (Multi l) cid (Just flw) jobHandle
-          -- printDebug "corpus id" cids
+          corpusId <- flowDataText user txt (Multi l) cid (Just flw) jobHandle
+          $(logLocM) DEBUG $ T.pack $ "corpus id " <> show corpusId
           -- printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
           sendMail user
           -- TODO ...
@@ -247,6 +248,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
 
         Left err -> do
           -- printDebug "Error: " err
+          $(logLocM) ERROR (T.pack $ show err)
           markFailed (Just $ T.pack (show err)) jobHandle
 
 type AddWithForm = Summary "Add with FormUrlEncoded to corpus endpoint"

src/Gargantext/API/Prelude.hs

@@ -49,6 +49,7 @@ import Servant
 import Servant.Job.Async
 import Servant.Job.Core (HasServerError(..), serverError)
 import qualified Servant.Job.Types as SJ
+import Gargantext.System.Logging
 
 class HasJoseError e where
   _JoseError :: Prism' e Jose.Error
@@ -88,7 +89,7 @@ type GargServerC env err m =
 
 type GargServerT env err m api = GargServerC env err m => ServerT api m
 
-type GargServer api = forall env err m. GargServerT env err m api
+type GargServer api = forall env err m. MonadLogger m => GargServerT env err m api
 
 -- This is the concrete monad. It needs to be used as little as possible.
 type GargM env err = ReaderT env (ExceptT err IO)

src/Gargantext/Database/Action/Flow.hs

@@ -55,9 +55,11 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
 
 import Conduit
 import Control.Lens hiding (elements, Indexed)
+import Control.Monad (void)
 import Data.Aeson.TH (deriveJSON)
 import Data.Conduit.Internal (zipSources)
 import Data.Either
+import Data.Foldable (for_)
 import Data.HashMap.Strict (HashMap)
 import Data.Hashable (Hashable)
 import Data.List (concat)
@@ -69,6 +71,7 @@ import Data.Set (Set)
 import Data.Swagger
 import Data.Tuple.Extra (first, second)
 import GHC.Generics (Generic)
+import GHC.Num (fromInteger)
 import Gargantext.API.Ngrams.Tools (getTermsWith)
 import Gargantext.Core (Lang(..), PosTagAlgo(..))
 import Gargantext.Core (withDefaultLanguage)
@@ -97,7 +100,7 @@ import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContex
 import Gargantext.Database.Action.Search (searchDocInDatabase)
 import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
 import Gargantext.Database.Admin.Types.Hyperdata
-import Gargantext.Database.Admin.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
+import Gargantext.Database.Admin.Types.Node hiding (DEBUG) -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.ContextNodeNgrams2
 import Gargantext.Database.Query.Table.Ngrams
@@ -113,26 +116,28 @@ import Gargantext.Database.Schema.Node (node_hyperdata)
 import Gargantext.Database.Types
 import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Hash (Hash)
+import Gargantext.System.Logging
 import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
 import System.FilePath (FilePath)
 import qualified Data.Conduit      as C
 import qualified Data.Conduit.List as CL
 import qualified Data.Conduit.List as CList
 import qualified Data.HashMap.Strict as HashMap
+import qualified Data.List as List
 import qualified Data.Map.Strict as Map
 import qualified Data.Set            as Set
 import qualified Data.Text as T
 import qualified Gargantext.API.Ngrams.Types as NT
 import qualified Gargantext.Core.Text.Corpus.API as API
 import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
-import qualified Gargantext.Database.Query.Table.Node.Document.Add  as Doc  (add)
+import qualified Gargantext.Database.Query.Table.Node.Document.Add  as Doc (add)
 import qualified PUBMED.Types as PUBMED
 
 ------------------------------------------------------------------------
 -- Imports for upgrade function
 import Gargantext.Database.Query.Tree.Root (getRootId)
 import Gargantext.Database.Query.Tree (findNodesId)
-import qualified Data.List as List
+
 ------------------------------------------------------------------------
 -- TODO use internal with API name (could be old data)
 data DataOrigin = InternalOrigin { _do_api :: API.ExternalAPIs }
@@ -205,12 +210,15 @@ flowDataText :: forall env err m.
                 -> JobHandle m
                 -> m CorpusId
 flowDataText u (DataOld ids) tt cid mfslw _ = do
+  $(logLocM) DEBUG $ T.pack $ "Found " <> show (length ids) <> " old node IDs"
   (_userId, userCorpusId, listId) <- createNodes u (Right [cid]) corpusType
   _ <- Doc.add userCorpusId ids
   flowCorpusUser (_tt_lang tt) u userCorpusId listId corpusType mfslw
   where
     corpusType = (Nothing :: Maybe HyperdataCorpus)
-flowDataText u (DataNew (mLen, txtC)) tt cid mfslw jobHandle =
+flowDataText u (DataNew (mLen, txtC)) tt cid mfslw jobHandle = do
+  $(logLocM) DEBUG $ T.pack $ "Found " <> show mLen <> " new documents to process"
+  for_ (mLen <&> fromInteger) (`addMoreSteps` jobHandle)
   flowCorpus u (Right [cid]) tt mfslw (mLen, (transPipe liftBase txtC)) jobHandle
 
 ------------------------------------------------------------------------
@@ -279,59 +287,23 @@ flow :: forall env err m a c.
 flow c u cn la mfslw (mLength, docsC) jobHandle = do
   (_userId, userCorpusId, listId) <- createNodes u cn c
   -- TODO if public insertMasterDocs else insertUserDocs
-  _ <- runConduit $ zipSources (yieldMany [1..]) docsC
+  runConduit $ zipSources (yieldMany [1..]) docsC
                  .| CList.chunksOf 100
-                 .| mapMC insertDocs'
-                 .| mapM_C (\ids' -> do
-                               _ <- Doc.add userCorpusId ids'
-                               pure ())
-                 .| sinkList
-
-  _ <- flowCorpusUser (la ^. tt_lang) u userCorpusId listId c mfslw
-
---  ids <- traverse (\(idx, doc) -> do
---                      id <- insertMasterDocs c la doc
---                      logStatus JobLog { _scst_succeeded = Just $ 1 + idx
---                                       , _scst_failed    = Just 0
---                                       , _scst_remaining = Just $ length docs - idx
---                                       , _scst_events    = Just []
---                                       }
---                      pure id
---                  ) (zip [1..] docs)
-  --printDebug "[flow] calling flowCorpusUser" (0 :: Int)
-  pure userCorpusId
-  --flowCorpusUser (la ^. tt_lang) u cn c ids mfslw
+                 .| mapM_C (\docs -> void $ insertDocs' docs >>= Doc.add userCorpusId)
+                 .| sinkNull
+
+  $(logLocM) DEBUG "Calling flowCorpusUser"
+  flowCorpusUser (la ^. tt_lang) u userCorpusId listId c mfslw
 
   where
     insertDocs' :: [(Integer, a)] -> m [NodeId]
     insertDocs' [] = pure []
     insertDocs' docs = do
-      -- printDebug "[flow] calling insertDoc, ([idx], mLength) = " (fst <$> docs, mLength)
+      $(logLocM) DEBUG $ T.pack $ "calling insertDoc, ([idx], mLength) = " <> show (fst <$> docs, mLength)
       ids <- insertMasterDocs c la (snd <$> docs)
-      let maxIdx = maximum (fst <$> docs)
-      case mLength of
-        Nothing -> pure ()
-        Just _len -> do
-
-          let succeeded = fromIntegral (1 + maxIdx)
-          -- let remaining = fromIntegral (len - maxIdx)
-          -- Reconstruct the correct update state by using 'markStarted' and the other primitives.
-          -- We do this slightly awkward arithmetic such that when we call 'markProgress' we reduce
-          -- the number of 'remaining' of exactly '1 + maxIdx', and we will end up with a 'JobLog'
-          -- looking like this:
-          -- JobLog
-          -- { _scst_succeeded = Just $ fromIntegral $ 1 + maxIdx
-          -- , _scst_failed    = Just 0
-          -- , _scst_remaining = Just $ fromIntegral $ len - maxIdx
-          -- , _scst_events    = Just []
-          -- }
-          -- markStarted (remaining + succeeded) jobHandle
-          markProgress succeeded jobHandle
-
+      markProgress (length docs) jobHandle
       pure ids
 
-
-
 ------------------------------------------------------------------------
 createNodes :: ( FlowCmdM env err m
                , MkCorpus c

src/Gargantext/Database/Action/Flow/Types.hs

@@ -30,6 +30,7 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Prelude (CmdM)
 import Gargantext.Database.Query.Table.Node.Document.Insert
 import Gargantext.Database.Query.Tree.Error (HasTreeError)
+import Gargantext.System.Logging
 
 type FlowCmdM env err m =
   ( CmdM     env err m
@@ -37,6 +38,7 @@ type FlowCmdM env err m =
   , HasNodeError err
   , HasInvalidError err
   , HasTreeError err
+  , MonadLogger m
   )
 
 type FlowCorpus a = ( AddUniqId      a

src/Gargantext/Database/Query/Table/Node/Document/Add.hs

@@ -39,6 +39,13 @@ add pId ns = runPGSQuery queryAdd (Only $ Values fields inputData)
     fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
     inputData = prepare pId ns
 
+-- | Adds a single document. Useful for debugging purposes, but
+-- not as efficient as adding documents in bulk via 'add'.
+add_one :: CorpusId -> ContextId -> Cmd err [Only Int]
+add_one pId ctxId = runPGSQuery queryAdd (Only $ Values fields [InputData pId ctxId])
+  where
+    fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
+
 add_debug :: CorpusId -> [ContextId] -> Cmd err ByteString
 add_debug pId ns = formatPGSQuery queryAdd (Only $ Values fields inputData)
   where

src/Gargantext/System/Logging.hs

+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies    #-}
+
+module Gargantext.System.Logging (
+    LogLevel(..)
+  , HasLogger(..)
+  , MonadLogger(..)
+  , logM
+  , logLocM
+  , withLogger
+  , withLoggerHoisted
+  ) where
+
+import Language.Haskell.TH hiding (Type)
+import Control.Exception.Lifted (bracket)
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Control
+import Data.Kind (Type)
+import Prelude
+import qualified Data.Text as T
+import qualified Language.Haskell.TH.Syntax        as TH
+
+data LogLevel =
+  -- | Debug messages
+  DEBUG
+  -- | Information
+  | INFO
+  -- | Normal runtime conditions
+  | NOTICE
+  -- | General Warnings
+  | WARNING
+  -- | General Errors
+  | ERROR
+  -- | Severe situations
+  | CRITICAL
+  -- | Take immediate action
+  | ALERT
+  -- | System is unusable
+  | EMERGENCY
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+-- | This is a barebore logging interface which we
+-- can extend to plug a proper logging library, without
+-- the details of the logger cropping up everywhere in
+-- the rest of the codebase.
+class HasLogger m where
+  data family Logger m        :: Type
+  type family LogInitParams m :: Type
+  type family LogPayload m    :: Type
+  initLogger    :: LogInitParams m -> (forall m1. MonadIO m1 => m1 (Logger m))
+  destroyLogger :: Logger m        -> (forall m1. MonadIO m1 => m1 ())
+  logMsg        :: Logger m        -> LogLevel -> LogPayload m -> m ()
+  logTxt        :: Logger m        -> LogLevel -> T.Text -> m ()
+
+-- | Separate typeclass to get hold of a 'Logger' from within a monad.
+-- We keey 'HasLogger' and 'MonadLogger' separate to enforce compositionality,
+-- i.e. we can still give instances to 'HasLogger' for things like 'IO' without
+-- having to force actually acquiring a logger for those monads.
+class HasLogger m => MonadLogger m where
+  getLogger :: m (Logger m)
+
+-- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
+logM :: (Monad m, MonadLogger m) => LogLevel -> T.Text -> m ()
+logM level msg = do
+  logger <- getLogger
+  logTxt logger level msg
+
+-- | Like 'logM', but it automatically adds the file and line number to
+-- the output log.
+logLocM :: ExpQ
+logLocM = [| \level msg ->
+  let loc = $(getLocTH)
+  in logM level (formatWithLoc loc msg)
+  |]
+
+formatWithLoc :: Loc -> T.Text -> T.Text
+formatWithLoc loc msg = "[" <> locationToText <> "] " <> msg
+  where
+    locationToText :: T.Text
+    locationToText = T.pack $ (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
+      where
+        line = show . fst . loc_start
+        char = show . snd . loc_start
+
+getLocTH :: ExpQ
+getLocTH = [| $(location >>= liftLoc) |]
+
+liftLoc :: Loc -> Q Exp
+liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
+    $(TH.lift a)
+    $(TH.lift b)
+    $(TH.lift c)
+    ($(TH.lift d1), $(TH.lift d2))
+    ($(TH.lift e1), $(TH.lift e2))
+    |]
+
+-- | exception-safe combinator that creates and destroys a logger.
+-- Think about it like a 'bracket' function from 'Control.Exception'.
+withLogger :: (MonadBaseControl IO m, MonadIO m, HasLogger m)
+           => LogInitParams m
+           -> (Logger m -> m a)
+           -> m a
+withLogger params = bracket (initLogger params) destroyLogger
+
+-- | Like 'withLogger', but it allows creating a 'Logger' that can run in
+-- a different monad from within an 'IO' action.
+withLoggerHoisted :: (MonadBaseControl IO m, HasLogger m)
+                  => LogInitParams m
+                  -> (Logger m -> IO a)
+                  -> IO a
+withLoggerHoisted params act = bracket (initLogger params) destroyLogger act

src/Gargantext/Utils/Jobs/Monad.hs

@@ -212,3 +212,6 @@ class MonadJobStatus m where
   -- | Finish tracking a job by marking all the remaining steps as failed. Attach an optional
   -- message to the failure.
   markFailed :: Maybe T.Text -> JobHandle m -> m ()
+
+  -- | Add 'n' more steps to the running computation, they will be marked as remaining.
+  addMoreSteps :: MonadJobStatus m => Int -> JobHandle m -> m ()