Skip to content

haskell-gargantext
haskell-gargantext
Commit bb78d480 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

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

parents e30d8cb7 0ce35337
Hide whitespace changes
Inline Side-by-side
Showing with 270 additions and 85 deletions
bin/gargantext-server/Main.hs
View file @ bb78d480
......@@ -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
View file @ bb78d480
......@@ -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
View file @ bb78d480
......@@ -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
View file @ bb78d480
......@@ -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
View file @ bb78d480
......@@ -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
View file @ bb78d480
......@@ -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
View file @ bb78d480
......@@ -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
View file @ bb78d480
......@@ -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
View file @ bb78d480
......@@ -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
View file @ bb78d480
......@@ -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
View file @ bb78d480
......@@ -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
View file @ bb78d480
......@@ -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
View file @ bb78d480
......@@ -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 0 → 100644
View file @ bb78d480
{-# 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
View file @ bb78d480
......@@ -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 ()
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