Commit bb78d480 authored by Alexandre Delanoë's avatar Alexandre Delanoë

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

parents e30d8cb7 0ce35337
...@@ -16,15 +16,19 @@ Script to start gargantext with different modes (Dev, Prod, Mock). ...@@ -16,15 +16,19 @@ Script to start gargantext with different modes (Dev, Prod, Mock).
{-# LANGUAGE Strict #-} {-# LANGUAGE Strict #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies #-}
module Main where module Main where
import Data.String (String)
import Data.Text (unpack) import Data.Text (unpack)
import Data.Version (showVersion) 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.Prelude
import Gargantext.System.Logging
import Options.Generic import Options.Generic
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import qualified Paths_gargantext as PG -- cabal magic build module import qualified Paths_gargantext as PG -- cabal magic build module
...@@ -49,14 +53,26 @@ data MyOptions w = ...@@ -49,14 +53,26 @@ data MyOptions w =
instance ParseRecord (MyOptions Wrapped) instance ParseRecord (MyOptions Wrapped)
deriving instance Show (MyOptions Unwrapped) 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 :: IO ()
main = do main = withLogger () $ \ioLogger -> do
MyOptions myMode myPort myIniFile myVersion <- unwrapRecord MyOptions myMode myPort myIniFile myVersion <- unwrapRecord
"Gargantext server" "Gargantext server"
--------------------------------------------------------------- ---------------------------------------------------------------
if myVersion then do if myVersion then do
putStrLn $ "Version: " <> showVersion PG.version logMsg ioLogger INFO $ "Version: " <> showVersion PG.version
System.Exit.exitSuccess System.Exit.exitSuccess
else else
return () return ()
...@@ -73,6 +89,6 @@ main = do ...@@ -73,6 +89,6 @@ main = do
let start = case myMode of let start = case myMode of
Mock -> panic "[ERROR] Mock mode unsupported" Mock -> panic "[ERROR] Mock mode unsupported"
_ -> startGargantext myMode myPort' (unpack myIniFile') _ -> startGargantext myMode myPort' (unpack myIniFile')
putStrLn $ "Starting with " <> show myMode <> " mode." logMsg ioLogger INFO $ "Starting with " <> show myMode <> " mode."
start start
--------------------------------------------------------------- ---------------------------------------------------------------
...@@ -79,7 +79,7 @@ source-repository-package ...@@ -79,7 +79,7 @@ source-repository-package
source-repository-package source-repository-package
type: git type: git
location: https://gitlab.iscpif.fr/gargantext/crawlers/arxiv-api.git location: https://gitlab.iscpif.fr/gargantext/crawlers/arxiv-api.git
tag: 2d7e5753cbbce248b860b571a0e9885415c846f7 tag: eb130c71fa17adaceed6ff66beefbccb13df51ba
source-repository-package source-repository-package
type: git type: git
......
...@@ -117,6 +117,7 @@ library ...@@ -117,6 +117,7 @@ library
Gargantext.Database.Query.Table.Node.UpdateOpaleye Gargantext.Database.Query.Table.Node.UpdateOpaleye
Gargantext.Database.Query.Table.User Gargantext.Database.Query.Table.User
Gargantext.Database.Schema.Ngrams Gargantext.Database.Schema.Ngrams
Gargantext.System.Logging
Gargantext.Defaults Gargantext.Defaults
Gargantext.Utils.Jobs Gargantext.Utils.Jobs
Gargantext.Utils.Jobs.Internal Gargantext.Utils.Jobs.Internal
......
...@@ -29,13 +29,14 @@ Pouillard (who mainly made it). ...@@ -29,13 +29,14 @@ Pouillard (who mainly made it).
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
module Gargantext.API module Gargantext.API
where where
import Control.Concurrent import Control.Concurrent
import Control.Exception (catch, finally, SomeException{-, displayException, IOException-}) import Control.Exception (catch, finally, SomeException{-, displayException, IOException-})
import Control.Lens import Control.Lens hiding (Level)
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Reader (runReaderT) import Control.Monad.Reader (runReaderT)
import Data.Either import Data.Either
...@@ -46,9 +47,8 @@ import Data.Text.Encoding (encodeUtf8) ...@@ -46,9 +47,8 @@ import Data.Text.Encoding (encodeUtf8)
import Data.Text.IO (putStrLn) import Data.Text.IO (putStrLn)
import Data.Validity import Data.Validity
import GHC.Base (Applicative) import GHC.Base (Applicative)
import GHC.Generics (Generic)
import Gargantext.API.Admin.Auth.Types (AuthContext) 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.Settings (newEnv)
import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings) import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
import Gargantext.API.EKG import Gargantext.API.EKG
...@@ -69,14 +69,12 @@ import Servant ...@@ -69,14 +69,12 @@ import Servant
import System.FilePath import System.FilePath
import qualified Gargantext.Database.Prelude as DB import qualified Gargantext.Database.Prelude as DB
import qualified System.Cron.Schedule as Cron import qualified System.Cron.Schedule as Cron
import Gargantext.System.Logging
data Mode = Dev | Mock | Prod
deriving (Show, Read, Generic)
-- | startGargantext takes as parameters port number and Ini file. -- | startGargantext takes as parameters port number and Ini file.
startGargantext :: Mode -> PortNumber -> FilePath -> IO () startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
startGargantext mode port file = do startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
env <- newEnv port file env <- newEnv logger port file
runDbCheck env runDbCheck env
portRouteInfo port portRouteInfo port
app <- makeApp env app <- makeApp env
......
...@@ -2,15 +2,18 @@ ...@@ -2,15 +2,18 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
module Gargantext.API.Admin.EnvTypes ( module Gargantext.API.Admin.EnvTypes (
GargJob(..) GargJob(..)
, Env(..) , Env(..)
, Mode(..)
, mkJobHandle , mkJobHandle
, env_logger , env_logger
, env_manager , env_manager
, env_self_url , env_self_url
, menv_firewall , menv_firewall
, dev_env_logger
, MockEnv(..) , MockEnv(..)
, DevEnv(..) , DevEnv(..)
...@@ -18,7 +21,7 @@ module Gargantext.API.Admin.EnvTypes ( ...@@ -18,7 +21,7 @@ module Gargantext.API.Admin.EnvTypes (
, ConcreteJobHandle -- opaque , ConcreteJobHandle -- opaque
) where ) where
import Control.Lens hiding ((:<)) import Control.Lens hiding (Level, (:<))
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Reader import Control.Monad.Reader
import Data.Pool (Pool) import Data.Pool (Pool)
...@@ -29,24 +32,62 @@ import Network.HTTP.Client (Manager) ...@@ -29,24 +32,62 @@ import Network.HTTP.Client (Manager)
import Servant.Client (BaseUrl) import Servant.Client (BaseUrl)
import Servant.Job.Async (HasJobEnv(..), Job) import Servant.Job.Async (HasJobEnv(..), Job)
import qualified Servant.Job.Async as SJ import qualified Servant.Job.Async as SJ
import System.Log.FastLogger
import qualified Servant.Job.Core 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.Orchestrator.Types
import Gargantext.API.Admin.Types
import Gargantext.API.Job import Gargantext.API.Job
import Gargantext.API.Prelude (GargM) import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.Core.NodeStory
import Gargantext.Core.Mail.Types (HasMail, mailSettings) import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..)) import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..)) import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..)) import Gargantext.Prelude.Config (GargConfig(..))
import Gargantext.Prelude.Mail.Types (MailConfig) 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 qualified Gargantext.Utils.Jobs.Monad as Jobs
import Gargantext.Utils.Jobs.Map (LoggerM, J(..), jTask, rjGetLog) 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 data GargJob
= TableNgramsJob = TableNgramsJob
| ForgotPasswordJob | ForgotPasswordJob
...@@ -72,7 +113,7 @@ data GargJob ...@@ -72,7 +113,7 @@ data GargJob
-- we need to remember to force the fields to WHNF at that point. -- we need to remember to force the fields to WHNF at that point.
data Env = Env data Env = Env
{ _env_settings :: ~Settings { _env_settings :: ~Settings
, _env_logger :: ~LoggerSet , _env_logger :: ~(Logger (GargM Env GargError))
, _env_pool :: ~(Pool Connection) , _env_pool :: ~(Pool Connection)
, _env_nodeStory :: ~NodeStoryEnv , _env_nodeStory :: ~NodeStoryEnv
, _env_manager :: ~Manager , _env_manager :: ~Manager
...@@ -186,6 +227,8 @@ instance Jobs.MonadJobStatus (GargM Env err) where ...@@ -186,6 +227,8 @@ instance Jobs.MonadJobStatus (GargM Env err) where
Just msg -> jobLogFailTotalWithMessage msg latest Just msg -> jobLogFailTotalWithMessage msg latest
) )
addMoreSteps steps jh = updateJobProgress jh (jobLogAddMore steps)
data MockEnv = MockEnv data MockEnv = MockEnv
{ _menv_firewall :: !FireWall { _menv_firewall :: !FireWall
} }
...@@ -193,9 +236,31 @@ data MockEnv = MockEnv ...@@ -193,9 +236,31 @@ data MockEnv = MockEnv
makeLenses ''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 data DevEnv = DevEnv
{ _dev_env_settings :: !Settings { _dev_env_settings :: !Settings
, _dev_env_config :: !GargConfig , _dev_env_config :: !GargConfig
, _dev_env_logger :: !(Logger (GargM DevEnv GargError))
, _dev_env_pool :: !(Pool Connection) , _dev_env_pool :: !(Pool Connection)
, _dev_env_nodeStory :: !NodeStoryEnv , _dev_env_nodeStory :: !NodeStoryEnv
, _dev_env_mail :: !MailConfig , _dev_env_mail :: !MailConfig
...@@ -229,6 +294,8 @@ instance Jobs.MonadJobStatus (GargM DevEnv err) where ...@@ -229,6 +294,8 @@ instance Jobs.MonadJobStatus (GargM DevEnv err) where
markFailed _ _ = pure () markFailed _ _ = pure ()
addMoreSteps _ _ = pure ()
instance HasConfig DevEnv where instance HasConfig DevEnv where
hasConfig = dev_env_config hasConfig = dev_env_config
......
...@@ -37,12 +37,12 @@ import System.Directory ...@@ -37,12 +37,12 @@ import System.Directory
-- import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive)) -- import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
import System.IO (FilePath, hClose) import System.IO (FilePath, hClose)
import System.IO.Temp (withTempFile) import System.IO.Temp (withTempFile)
import System.Log.FastLogger
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Gargantext.API.Admin.EnvTypes import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Types 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.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
import Gargantext.Core.NLP (nlpServerMap) import Gargantext.Core.NLP (nlpServerMap)
import Gargantext.Database.Prelude (databaseParameters, hasConfig) import Gargantext.Database.Prelude (databaseParameters, hasConfig)
...@@ -54,6 +54,7 @@ import qualified Gargantext.Utils.Jobs as Jobs ...@@ -54,6 +54,7 @@ import qualified Gargantext.Utils.Jobs as Jobs
import qualified Gargantext.Utils.Jobs.Monad as Jobs import qualified Gargantext.Utils.Jobs.Monad as Jobs
import qualified Gargantext.Utils.Jobs.Queue as Jobs import qualified Gargantext.Utils.Jobs.Queue as Jobs
import qualified Gargantext.Utils.Jobs.Settings as Jobs import qualified Gargantext.Utils.Jobs.Settings as Jobs
import Gargantext.System.Logging
devSettings :: FilePath -> IO Settings devSettings :: FilePath -> IO Settings
devSettings jwkFile = do devSettings jwkFile = do
...@@ -176,8 +177,8 @@ readRepoEnv repoDir = do ...@@ -176,8 +177,8 @@ readRepoEnv repoDir = do
devJwkFile :: FilePath devJwkFile :: FilePath
devJwkFile = "dev.jwk" devJwkFile = "dev.jwk"
newEnv :: PortNumber -> FilePath -> IO Env newEnv :: Logger (GargM Env GargError) -> PortNumber -> FilePath -> IO Env
newEnv port file = do newEnv logger port file = do
!manager_env <- newTlsManager !manager_env <- newTlsManager
!settings' <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file' !settings' <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
when (port /= settings' ^. appPort) $ when (port /= settings' ^. appPort) $
...@@ -200,7 +201,6 @@ newEnv port file = do ...@@ -200,7 +201,6 @@ newEnv port file = do
& Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_job_timeout) & Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_job_timeout)
& Jobs.l_jsIDTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_id_timeout) & Jobs.l_jsIDTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_id_timeout)
!jobs_env <- Jobs.newJobEnv jobs_settings prios' manager_env !jobs_env <- Jobs.newJobEnv jobs_settings prios' manager_env
!logger <- newStderrLoggerSet defaultBufSize
!config_mail <- Mail.readConfig file !config_mail <- Mail.readConfig file
!nlp_env <- nlpServerMap <$> NLP.readConfig file !nlp_env <- nlpServerMap <$> NLP.readConfig file
......
...@@ -29,16 +29,17 @@ import qualified Gargantext.Prelude.Mail as Mail ...@@ -29,16 +29,17 @@ import qualified Gargantext.Prelude.Mail as Mail
import qualified Gargantext.Prelude.NLP as NLP import qualified Gargantext.Prelude.NLP as NLP
import Servant import Servant
import System.IO (FilePath) import System.IO (FilePath)
import Gargantext.System.Logging
type IniPath = FilePath type IniPath = FilePath
------------------------------------------------------------------- -------------------------------------------------------------------
withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
withDevEnv iniPath k = do withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do
env <- newDevEnv env <- newDevEnv logger
k env -- `finally` cleanEnv env k env -- `finally` cleanEnv env
where where
newDevEnv = do newDevEnv logger = do
cfg <- readConfig iniPath cfg <- readConfig iniPath
dbParam <- databaseParameters iniPath dbParam <- databaseParameters iniPath
--nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg) --nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
...@@ -49,6 +50,7 @@ withDevEnv iniPath k = do ...@@ -49,6 +50,7 @@ withDevEnv iniPath k = do
nlp_config <- NLP.readConfig iniPath nlp_config <- NLP.readConfig iniPath
pure $ DevEnv pure $ DevEnv
{ _dev_env_pool = pool { _dev_env_pool = pool
, _dev_env_logger = logger
, _dev_env_nodeStory = nodeStory_env , _dev_env_nodeStory = nodeStory_env
, _dev_env_settings = setts , _dev_env_settings = setts
, _dev_env_config = cfg , _dev_env_config = cfg
......
...@@ -31,7 +31,7 @@ addErrorEvent message = addEvent "ERROR" message ...@@ -31,7 +31,7 @@ addErrorEvent message = addEvent "ERROR" message
jobLogProgress :: Int -> JobLog -> JobLog jobLogProgress :: Int -> JobLog -> JobLog
jobLogProgress n jl = over (scst_succeeded . _Just) (+ n) $ 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'. -- | 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'. -- At the end 'scst_remaining' will be 0, and 'scst_succeeded' will be 'oldvalue + remaining'.
...@@ -41,6 +41,9 @@ jobLogComplete jl = ...@@ -41,6 +41,9 @@ jobLogComplete jl =
in jl & over scst_succeeded (Just . maybe remainingNow ((+) remainingNow)) in jl & over scst_succeeded (Just . maybe remainingNow ((+) remainingNow))
& over scst_remaining (const (Just 0)) & over scst_remaining (const (Just 0))
jobLogAddMore :: Int -> JobLog -> JobLog
jobLogAddMore moreSteps jl = jl & over (scst_remaining . _Just) (+ moreSteps)
jobLogFailures :: Int -> JobLog -> JobLog jobLogFailures :: Int -> JobLog -> JobLog
jobLogFailures n jl = over (scst_failed . _Just) (+ n) $ jobLogFailures n jl = over (scst_failed . _Just) (+ n) $
over (scst_remaining . _Just) (\x -> x - n) jl over (scst_remaining . _Just) (\x -> x - n) jl
......
...@@ -21,7 +21,6 @@ module Gargantext.API.Node.Corpus.New ...@@ -21,7 +21,6 @@ module Gargantext.API.Node.Corpus.New
import Conduit import Conduit
import Control.Lens hiding (elements, Empty) import Control.Lens hiding (elements, Empty)
import Control.Monad
import Data.Aeson import Data.Aeson
import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
import qualified Data.ByteString.Base64 as BSB64 import qualified Data.ByteString.Base64 as BSB64
...@@ -67,6 +66,7 @@ import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..)) ...@@ -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.API as API
import qualified Gargantext.Core.Text.Corpus.Parsers as Parser (FileType(..), parseFormatC) import qualified Gargantext.Core.Text.Corpus.Parsers as Parser (FileType(..), parseFormatC)
import qualified Gargantext.Database.GargDB as GargDB import qualified Gargantext.Database.GargDB as GargDB
import Gargantext.System.Logging
------------------------------------------------------------------------ ------------------------------------------------------------------------
{- {-
...@@ -201,16 +201,17 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q ...@@ -201,16 +201,17 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
, _wq_datafield = datafield , _wq_datafield = datafield
, _wq_lang = l , _wq_lang = l
, _wq_flowListWith = flw }) maybeLimit jobHandle = do , _wq_flowListWith = flw }) maybeLimit jobHandle = do
-- TODO ... -- TODO ...
-- printDebug "[addToCorpusWithQuery] (cid, dbs)" (cid, dbs) $(logLocM) DEBUG $ T.pack $ "(cid, dbs) " <> show (cid, dbs)
-- printDebug "[addToCorpusWithQuery] datafield" datafield $(logLocM) DEBUG $ T.pack $ "datafield " <> show datafield
-- printDebug "[addToCorpusWithQuery] flowListWith" flw $(logLocM) DEBUG $ T.pack $ "flowListWith " <> show flw
addLanguageToCorpus cid l addLanguageToCorpus cid l
case datafield of case datafield of
Just Web -> do Just Web -> do
-- printDebug "[addToCorpusWithQuery] processing web request" datafield $(logLocM) DEBUG $ T.pack $ "processing web request " <> show datafield
markStarted 1 jobHandle markStarted 1 jobHandle
...@@ -225,7 +226,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q ...@@ -225,7 +226,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
-- TODO if cid is folder -> create Corpus -- TODO if cid is folder -> create Corpus
-- if cid is corpus -> add to corpus -- if cid is corpus -> add to corpus
-- if cid is root -> create corpus in Private -- 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 let db = database2origin dbs
mPubmedAPIKey <- getUserPubmedAPIKey user mPubmedAPIKey <- getUserPubmedAPIKey user
-- printDebug "[addToCorpusWithQuery] mPubmedAPIKey" mPubmedAPIKey -- printDebug "[addToCorpusWithQuery] mPubmedAPIKey" mPubmedAPIKey
...@@ -235,11 +236,11 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q ...@@ -235,11 +236,11 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
case eTxt of case eTxt of
Right txt -> do Right txt -> do
-- TODO Sum lenghts of each txt elements -- TODO Sum lenghts of each txt elements
$(logLocM) DEBUG "Processing dataText results"
markProgress 1 jobHandle markProgress 1 jobHandle
void $ flowDataText user txt (Multi l) cid (Just flw) jobHandle corpusId <- flowDataText user txt (Multi l) cid (Just flw) jobHandle
-- printDebug "corpus id" cids $(logLocM) DEBUG $ T.pack $ "corpus id " <> show corpusId
-- printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text) -- printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
sendMail user sendMail user
-- TODO ... -- TODO ...
...@@ -247,6 +248,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q ...@@ -247,6 +248,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
Left err -> do Left err -> do
-- printDebug "Error: " err -- printDebug "Error: " err
$(logLocM) ERROR (T.pack $ show err)
markFailed (Just $ T.pack (show err)) jobHandle markFailed (Just $ T.pack (show err)) jobHandle
type AddWithForm = Summary "Add with FormUrlEncoded to corpus endpoint" type AddWithForm = Summary "Add with FormUrlEncoded to corpus endpoint"
......
...@@ -49,6 +49,7 @@ import Servant ...@@ -49,6 +49,7 @@ import Servant
import Servant.Job.Async import Servant.Job.Async
import Servant.Job.Core (HasServerError(..), serverError) import Servant.Job.Core (HasServerError(..), serverError)
import qualified Servant.Job.Types as SJ import qualified Servant.Job.Types as SJ
import Gargantext.System.Logging
class HasJoseError e where class HasJoseError e where
_JoseError :: Prism' e Jose.Error _JoseError :: Prism' e Jose.Error
...@@ -88,7 +89,7 @@ type GargServerC env err m = ...@@ -88,7 +89,7 @@ type GargServerC env err m =
type GargServerT env err m api = GargServerC env err m => ServerT api 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. -- This is the concrete monad. It needs to be used as little as possible.
type GargM env err = ReaderT env (ExceptT err IO) type GargM env err = ReaderT env (ExceptT err IO)
......
...@@ -55,9 +55,11 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list) ...@@ -55,9 +55,11 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
import Conduit import Conduit
import Control.Lens hiding (elements, Indexed) import Control.Lens hiding (elements, Indexed)
import Control.Monad (void)
import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
import Data.Conduit.Internal (zipSources) import Data.Conduit.Internal (zipSources)
import Data.Either import Data.Either
import Data.Foldable (for_)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Hashable (Hashable) import Data.Hashable (Hashable)
import Data.List (concat) import Data.List (concat)
...@@ -69,6 +71,7 @@ import Data.Set (Set) ...@@ -69,6 +71,7 @@ import Data.Set (Set)
import Data.Swagger import Data.Swagger
import Data.Tuple.Extra (first, second) import Data.Tuple.Extra (first, second)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import GHC.Num (fromInteger)
import Gargantext.API.Ngrams.Tools (getTermsWith) import Gargantext.API.Ngrams.Tools (getTermsWith)
import Gargantext.Core (Lang(..), PosTagAlgo(..)) import Gargantext.Core (Lang(..), PosTagAlgo(..))
import Gargantext.Core (withDefaultLanguage) import Gargantext.Core (withDefaultLanguage)
...@@ -97,7 +100,7 @@ import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContex ...@@ -97,7 +100,7 @@ import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContex
import Gargantext.Database.Action.Search (searchDocInDatabase) import Gargantext.Database.Action.Search (searchDocInDatabase)
import Gargantext.Database.Admin.Config (userMaster, corpusMasterName) import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
import Gargantext.Database.Admin.Types.Hyperdata 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.Prelude
import Gargantext.Database.Query.Table.ContextNodeNgrams2 import Gargantext.Database.Query.Table.ContextNodeNgrams2
import Gargantext.Database.Query.Table.Ngrams import Gargantext.Database.Query.Table.Ngrams
...@@ -113,12 +116,14 @@ import Gargantext.Database.Schema.Node (node_hyperdata) ...@@ -113,12 +116,14 @@ import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Database.Types import Gargantext.Database.Types
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Hash (Hash) import Gargantext.Prelude.Crypto.Hash (Hash)
import Gargantext.System.Logging
import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..)) import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
import System.FilePath (FilePath) import System.FilePath (FilePath)
import qualified Data.Conduit as C import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import qualified Data.Conduit.List as CList import qualified Data.Conduit.List as CList
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as T import qualified Data.Text as T
...@@ -132,7 +137,7 @@ import qualified PUBMED.Types as PUBMED ...@@ -132,7 +137,7 @@ import qualified PUBMED.Types as PUBMED
-- Imports for upgrade function -- Imports for upgrade function
import Gargantext.Database.Query.Tree.Root (getRootId) import Gargantext.Database.Query.Tree.Root (getRootId)
import Gargantext.Database.Query.Tree (findNodesId) import Gargantext.Database.Query.Tree (findNodesId)
import qualified Data.List as List
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- TODO use internal with API name (could be old data) -- TODO use internal with API name (could be old data)
data DataOrigin = InternalOrigin { _do_api :: API.ExternalAPIs } data DataOrigin = InternalOrigin { _do_api :: API.ExternalAPIs }
...@@ -205,12 +210,15 @@ flowDataText :: forall env err m. ...@@ -205,12 +210,15 @@ flowDataText :: forall env err m.
-> JobHandle m -> JobHandle m
-> m CorpusId -> m CorpusId
flowDataText u (DataOld ids) tt cid mfslw _ = do 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 (_userId, userCorpusId, listId) <- createNodes u (Right [cid]) corpusType
_ <- Doc.add userCorpusId ids _ <- Doc.add userCorpusId ids
flowCorpusUser (_tt_lang tt) u userCorpusId listId corpusType mfslw flowCorpusUser (_tt_lang tt) u userCorpusId listId corpusType mfslw
where where
corpusType = (Nothing :: Maybe HyperdataCorpus) 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 flowCorpus u (Right [cid]) tt mfslw (mLen, (transPipe liftBase txtC)) jobHandle
------------------------------------------------------------------------ ------------------------------------------------------------------------
...@@ -279,59 +287,23 @@ flow :: forall env err m a c. ...@@ -279,59 +287,23 @@ flow :: forall env err m a c.
flow c u cn la mfslw (mLength, docsC) jobHandle = do flow c u cn la mfslw (mLength, docsC) jobHandle = do
(_userId, userCorpusId, listId) <- createNodes u cn c (_userId, userCorpusId, listId) <- createNodes u cn c
-- TODO if public insertMasterDocs else insertUserDocs -- TODO if public insertMasterDocs else insertUserDocs
_ <- runConduit $ zipSources (yieldMany [1..]) docsC runConduit $ zipSources (yieldMany [1..]) docsC
.| CList.chunksOf 100 .| CList.chunksOf 100
.| mapMC insertDocs' .| mapM_C (\docs -> void $ insertDocs' docs >>= Doc.add userCorpusId)
.| mapM_C (\ids' -> do .| sinkNull
_ <- Doc.add userCorpusId ids'
pure ()) $(logLocM) DEBUG "Calling flowCorpusUser"
.| sinkList flowCorpusUser (la ^. tt_lang) u userCorpusId listId c mfslw
_ <- 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
where where
insertDocs' :: [(Integer, a)] -> m [NodeId] insertDocs' :: [(Integer, a)] -> m [NodeId]
insertDocs' [] = pure [] insertDocs' [] = pure []
insertDocs' docs = do 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) ids <- insertMasterDocs c la (snd <$> docs)
let maxIdx = maximum (fst <$> docs) markProgress (length docs) jobHandle
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
pure ids pure ids
------------------------------------------------------------------------ ------------------------------------------------------------------------
createNodes :: ( FlowCmdM env err m createNodes :: ( FlowCmdM env err m
, MkCorpus c , MkCorpus c
......
...@@ -30,6 +30,7 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError) ...@@ -30,6 +30,7 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Prelude (CmdM) import Gargantext.Database.Prelude (CmdM)
import Gargantext.Database.Query.Table.Node.Document.Insert import Gargantext.Database.Query.Table.Node.Document.Insert
import Gargantext.Database.Query.Tree.Error (HasTreeError) import Gargantext.Database.Query.Tree.Error (HasTreeError)
import Gargantext.System.Logging
type FlowCmdM env err m = type FlowCmdM env err m =
( CmdM env err m ( CmdM env err m
...@@ -37,6 +38,7 @@ type FlowCmdM env err m = ...@@ -37,6 +38,7 @@ type FlowCmdM env err m =
, HasNodeError err , HasNodeError err
, HasInvalidError err , HasInvalidError err
, HasTreeError err , HasTreeError err
, MonadLogger m
) )
type FlowCorpus a = ( AddUniqId a type FlowCorpus a = ( AddUniqId a
......
...@@ -39,6 +39,13 @@ add pId ns = runPGSQuery queryAdd (Only $ Values fields inputData) ...@@ -39,6 +39,13 @@ add pId ns = runPGSQuery queryAdd (Only $ Values fields inputData)
fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
inputData = prepare pId ns 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 :: CorpusId -> [ContextId] -> Cmd err ByteString
add_debug pId ns = formatPGSQuery queryAdd (Only $ Values fields inputData) add_debug pId ns = formatPGSQuery queryAdd (Only $ Values fields inputData)
where where
......
{-# 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
...@@ -212,3 +212,6 @@ class MonadJobStatus m where ...@@ -212,3 +212,6 @@ class MonadJobStatus m where
-- | Finish tracking a job by marking all the remaining steps as failed. Attach an optional -- | Finish tracking a job by marking all the remaining steps as failed. Attach an optional
-- message to the failure. -- message to the failure.
markFailed :: Maybe T.Text -> JobHandle m -> m () 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 ()
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment