Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
119
Issues
119
List
Board
Labels
Milestones
Merge Requests
7
Merge Requests
7
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
bb78d480
Commit
bb78d480
authored
Aug 23, 2023
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Plain Diff
Merge remote-tracking branch 'origin/adinapoli/issue-258-part-2' into dev
parents
e30d8cb7
0ce35337
Changes
15
Show whitespace changes
Inline
Side-by-side
Showing
15 changed files
with
270 additions
and
85 deletions
+270
-85
Main.hs
bin/gargantext-server/Main.hs
+20
-4
cabal.project
cabal.project
+1
-1
gargantext.cabal
gargantext.cabal
+1
-0
API.hs
src/Gargantext/API.hs
+6
-8
EnvTypes.hs
src/Gargantext/API/Admin/EnvTypes.hs
+73
-6
Settings.hs
src/Gargantext/API/Admin/Settings.hs
+4
-4
Dev.hs
src/Gargantext/API/Dev.hs
+5
-3
Job.hs
src/Gargantext/API/Job.hs
+4
-1
New.hs
src/Gargantext/API/Node/Corpus/New.hs
+11
-9
Prelude.hs
src/Gargantext/API/Prelude.hs
+2
-1
Flow.hs
src/Gargantext/Database/Action/Flow.hs
+20
-48
Types.hs
src/Gargantext/Database/Action/Flow/Types.hs
+2
-0
Add.hs
src/Gargantext/Database/Query/Table/Node/Document/Add.hs
+7
-0
Logging.hs
src/Gargantext/System/Logging.hs
+111
-0
Monad.hs
src/Gargantext/Utils/Jobs/Monad.hs
+3
-0
No files found.
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
:
2
d7e5753cbbce248b860b571a0e9885415c846f7
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
''
M
ockEnv
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,12 +116,14 @@ 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
...
...
@@ -132,7 +137,7 @@ 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
()
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment