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
145
Issues
145
List
Board
Labels
Milestones
Merge Requests
6
Merge Requests
6
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
eca8f40d
Commit
eca8f40d
authored
Mar 26, 2025
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Plain Diff
Merge remote-tracking branch 'origin/adinapoli/issue-381' into dev-merge
parents
d9045574
3b114df3
Changes
20
Hide whitespace changes
Inline
Side-by-side
Showing
20 changed files
with
339 additions
and
205 deletions
+339
-205
gargantext.cabal
gargantext.cabal
+5
-0
hie.yaml
hie.yaml
+0
-6
API.hs
src/Gargantext/API.hs
+23
-22
EnvTypes.hs
src/Gargantext/API/Admin/EnvTypes.hs
+15
-34
Dev.hs
src/Gargantext/API/Dev.hs
+8
-8
List.hs
src/Gargantext/API/Ngrams/List.hs
+16
-12
Worker.hs
src/Gargantext/API/Worker.hs
+7
-2
Utils.hs
src/Gargantext/Core/Config/Utils.hs
+16
-26
TSV.hs
src/Gargantext/Core/Text/List/Formats/TSV.hs
+3
-1
Env.hs
src/Gargantext/Core/Worker/Env.hs
+24
-41
Logging.hs
src/Gargantext/System/Logging.hs
+6
-23
Loggers.hs
src/Gargantext/System/Logging/Loggers.hs
+74
-0
Termes_A_Ajouter_T4SC_Intellixir.tsv
test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir.tsv
+29
-0
Termes_A_Ajouter_T4SC_Intellixir12.csv
test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir12.csv
+29
-0
Private.hs
test/Test/API/Private.hs
+3
-0
List.hs
test/Test/API/Private/List.hs
+60
-0
Remote.hs
test/Test/API/Private/Remote.hs
+4
-3
Setup.hs
test/Test/API/Setup.hs
+6
-4
Setup.hs
test/Test/Database/Setup.hs
+3
-3
Types.hs
test/Test/Database/Types.hs
+8
-20
No files found.
gargantext.cabal
View file @
eca8f40d
...
...
@@ -54,6 +54,8 @@ data-files:
test-data/stemming/lancaster.txt
test-data/test_config.ini
test-data/test_config.toml
test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir.tsv
test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir12.csv
.clippy.dhall
-- common options
...
...
@@ -309,6 +311,7 @@ library
Gargantext.Orphans.Accelerate
Gargantext.Orphans.OpenAPI
Gargantext.System.Logging
Gargantext.System.Logging.Loggers
Gargantext.System.Logging.Types
Gargantext.Utils.Dict
Gargantext.Utils.Jobs.Error
...
...
@@ -803,6 +806,7 @@ test-suite garg-test-tasty
other-modules:
CLI.Phylo.Common
Paths_gargantext
Test.API.Private.List
Test.API.Private.Move
Test.API.Private.Remote
Test.API.Private.Share
...
...
@@ -877,6 +881,7 @@ test-suite garg-test-hspec
Test.API.GraphQL
Test.API.Notifications
Test.API.Private
Test.API.Private.List
Test.API.Private.Move
Test.API.Private.Remote
Test.API.Private.Share
...
...
hie.yaml
View file @
eca8f40d
...
...
@@ -68,9 +68,3 @@ cradle:
-
path
:
"
./test"
component
:
"
gargantext:test:garg-test-hspec"
-
path
:
"
./bench/Main.hs"
component
:
"
gargantext:bench:garg-bench"
-
path
:
"
./bench/Paths_gargantext.hs"
component
:
"
gargantext:bench:garg-bench"
src/Gargantext/API.hs
View file @
eca8f40d
...
...
@@ -70,29 +70,30 @@ import System.Cron.Schedule qualified as Cron
-- | startGargantext takes as parameters port number and Toml file.
startGargantext
::
Mode
->
PortNumber
->
SettingsFile
->
IO
()
startGargantext
mode
port
sf
@
(
SettingsFile
settingsFile
)
=
withLoggerIO
mode
$
\
logger
->
do
startGargantext
mode
port
sf
@
(
SettingsFile
settingsFile
)
=
do
config
<-
readConfig
sf
<&>
(
gc_frontend_config
.
fc_appPort
)
.~
port
when
(
port
/=
config
^.
gc_frontend_config
.
fc_appPort
)
$
panicTrace
"TODO: conflicting settings of port"
withNotifications
config
$
\
dispatcher
->
do
env
<-
newEnv
logger
config
dispatcher
let
fc
=
env
^.
env_config
.
gc_frontend_config
let
proxyStatus
=
microServicesProxyStatus
fc
runDbCheck
env
startupInfo
config
port
proxyStatus
app
<-
makeApp
env
mid
<-
makeGargMiddleware
(
fc
^.
fc_cors
)
mode
periodicActions
<-
schedulePeriodicActions
env
let
runServer
=
run
port
(
mid
app
)
`
finally
`
stopGargantext
periodicActions
case
proxyStatus
of
PXY_disabled
->
runServer
-- the proxy is disabled, do not spawn the application
PXY_enabled
proxyPort
->
do
proxyCache
<-
InMemory
.
newCache
(
Just
oneHour
)
let
runProxy
=
run
proxyPort
(
mid
(
microServicesProxyApp
proxyCache
env
))
Async
.
race_
runServer
runProxy
withLoggerIO
(
config
^.
gc_logging
)
$
\
logger
->
do
when
(
port
/=
config
^.
gc_frontend_config
.
fc_appPort
)
$
panicTrace
"TODO: conflicting settings of port"
withNotifications
config
$
\
dispatcher
->
do
env
<-
newEnv
logger
config
dispatcher
let
fc
=
env
^.
env_config
.
gc_frontend_config
let
proxyStatus
=
microServicesProxyStatus
fc
runDbCheck
env
startupInfo
config
port
proxyStatus
app
<-
makeApp
env
mid
<-
makeGargMiddleware
(
fc
^.
fc_cors
)
mode
periodicActions
<-
schedulePeriodicActions
env
let
runServer
=
run
port
(
mid
app
)
`
finally
`
stopGargantext
periodicActions
case
proxyStatus
of
PXY_disabled
->
runServer
-- the proxy is disabled, do not spawn the application
PXY_enabled
proxyPort
->
do
proxyCache
<-
InMemory
.
newCache
(
Just
oneHour
)
let
runProxy
=
run
proxyPort
(
mid
(
microServicesProxyApp
proxyCache
env
))
Async
.
race_
runServer
runProxy
where
runDbCheck
env
=
do
r
<-
runExceptT
(
runReaderT
DB
.
dbCheck
env
)
`
catch
`
...
...
src/Gargantext/API/Admin/EnvTypes.hs
View file @
eca8f40d
...
...
@@ -38,12 +38,11 @@ module Gargantext.API.Admin.EnvTypes (
import
Control.Lens
(
to
,
view
)
import
Data.List
((
\\
))
import
Data.Pool
(
Pool
)
import
Data.Text
qualified
as
T
import
Database.PostgreSQL.Simple
(
Connection
)
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
,
noJobLog
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Prelude
(
GargM
,
IsGargServer
)
import
Gargantext.Core.Config
(
GargConfig
(
..
),
gc_mail_config
,
gc_nlp_config
,
HasJWTSettings
(
..
),
HasConfig
(
..
),
HasManager
(
..
),
gc_logging
,
lc_log_level
)
import
Gargantext.Core.Config
import
Gargantext.Core.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
),
nlpServerMap
)
import
Gargantext.Core.NodeStory
...
...
@@ -58,6 +57,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
import
Network.HTTP.Client
(
Manager
)
import
Servant.Auth.Server
(
JWTSettings
)
import
System.Log.FastLogger
qualified
as
FL
import
Gargantext.System.Logging.Loggers
data
Mode
=
Dev
|
Mock
|
Prod
...
...
@@ -139,21 +139,13 @@ instance MonadLogger (GargM DevEnv BackendInternalError) where
instance
HasLogger
(
GargM
DevEnv
BackendInternalError
)
where
data
instance
Logger
(
GargM
DevEnv
BackendInternalError
)
=
GargDevLogger
{
dev_logger_mode
::
Mode
,
dev_logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
(
GargM
DevEnv
BackendInternalError
)
=
Mode
GargDevLogger
{
_GargDevLogger
::
MonadicStdLogger
FL
.
LogStr
IO
}
type
instance
LogInitParams
(
GargM
DevEnv
BackendInternalError
)
=
LogConfig
type
instance
LogPayload
(
GargM
DevEnv
BackendInternalError
)
=
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
<>
"] "
::
Text
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
)
initLogger
cfg
=
fmap
GargDevLogger
$
(
liftIO
$
monadicStdLogger
cfg
)
destroyLogger
=
liftIO
.
_msl_destroy
.
_GargDevLogger
logMsg
(
GargDevLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_msg
ioLogger
lvl
msg
logTxt
(
GargDevLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_txt
ioLogger
lvl
msg
data
DevEnv
=
DevEnv
{
_dev_env_config
::
!
GargConfig
...
...
@@ -225,25 +217,14 @@ instance HasNLPServer DevEnv where
instance
IsGargServer
Env
BackendInternalError
(
GargM
Env
BackendInternalError
)
instance
HasLogger
(
GargM
Env
BackendInternalError
)
where
data
instance
Logger
(
GargM
Env
BackendInternalError
)
=
GargLogger
{
logger_mode
::
Mode
,
logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
(
GargM
Env
BackendInternalError
)
=
Mode
newtype
instance
Logger
(
GargM
Env
BackendInternalError
)
=
GargLogger
{
_GargLogger
::
MonadicStdLogger
FL
.
LogStr
IO
}
type
instance
LogInitParams
(
GargM
Env
BackendInternalError
)
=
LogConfig
type
instance
LogPayload
(
GargM
Env
BackendInternalError
)
=
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
cfg
<-
view
hasConfig
let
minLvl
=
cfg
^.
gc_logging
.
lc_log_level
when
(
lvl
>=
minLvl
)
$
do
let
pfx
=
"["
<>
show
lvl
<>
"] "
::
Text
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
)
initLogger
cfg
=
fmap
GargLogger
$
(
liftIO
$
monadicStdLogger
cfg
)
destroyLogger
=
liftIO
.
_msl_destroy
.
_GargLogger
logMsg
(
GargLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_msg
ioLogger
lvl
msg
logTxt
(
GargLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_txt
ioLogger
lvl
msg
instance
MonadLogger
(
GargM
Env
BackendInternalError
)
where
getLogger
=
asks
_env_logger
src/Gargantext/API/Dev.hs
View file @
eca8f40d
...
...
@@ -16,11 +16,11 @@ import Control.Lens (view)
import
Control.Monad
(
fail
)
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Data.Pool
(
withResource
)
import
Gargantext.API.Admin.EnvTypes
(
DevEnv
(
..
)
,
Mode
(
Dev
)
)
import
Gargantext.API.Admin.EnvTypes
(
DevEnv
(
..
)
)
import
Gargantext.API.Admin.Settings
(
newPool
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.Core.Config
(
_gc_database_config
)
import
Gargantext.Core.Config
(
_gc_database_config
,
gc_logging
)
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.NodeStory
(
fromDBNodeStoryEnv
)
...
...
@@ -32,14 +32,14 @@ import Servant ( ServerError )
-------------------------------------------------------------------
withDevEnv
::
SettingsFile
->
(
DevEnv
->
IO
a
)
->
IO
a
withDevEnv
settingsFile
k
=
withLoggerIO
Dev
$
\
logger
->
do
env
<-
newDevEnv
logger
k
env
-- `finally` cleanEnv env
withDevEnv
settingsFile
k
=
do
cfg
<-
readConfig
settingsFile
withLoggerIO
(
cfg
^.
gc_logging
)
$
\
logger
->
do
env
<-
newDevEnv
logger
cfg
k
env
-- `finally` cleanEnv env
where
newDevEnv
logger
=
do
cfg
<-
readConfig
settingsFile
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
newDevEnv
logger
cfg
=
do
pool
<-
newPool
(
_gc_database_config
cfg
)
nodeStory_env
<-
fromDBNodeStoryEnv
pool
manager
<-
newTlsManager
...
...
src/Gargantext/API/Ngrams/List.hs
View file @
eca8f40d
...
...
@@ -21,21 +21,21 @@ import Data.ByteString.Lazy qualified as BSL
import
Data.Csv
qualified
as
Tsv
import
Data.HashMap.Strict
(
HashMap
)
import
Data.HashMap.Strict
qualified
as
HashMap
import
Data.Map.Strict
qualified
as
Map
import
Data.Map.Strict
(
toList
)
import
Data.Map.Strict
qualified
as
Map
import
Data.Set
qualified
as
Set
import
Data.Text
(
concat
,
pack
,
splitOn
)
import
Data.Vector
qualified
as
Vec
import
Data.Vector
(
Vector
)
import
Data.Vector
qualified
as
Vec
import
Gargantext.API.Admin.EnvTypes
(
Env
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
(
InternalServerError
))
import
Gargantext.API.Ngrams.List.Types
(
_wjf_data
,
_wtf_data
)
import
Gargantext.API.Ngrams.Prelude
(
getNgramsList
)
import
Gargantext.API.Ngrams
(
setListNgrams
)
import
Gargantext.API.Ngrams.List.Types
(
_wjf_data
,
_wtf_data
,
_wtf_name
)
import
Gargantext.API.Ngrams.Prelude
(
getNgramsList
)
import
Gargantext.API.Ngrams.Types
import
Gargantext.API.Prelude
(
GargM
,
serverError
,
HasServerError
)
import
Gargantext.API.Routes.Named.List
qualified
as
Named
import
Gargantext.API.Worker
(
serveWorkerAPI
,
serveWorkerAPI
EJob
)
import
Gargantext.API.Worker
(
serveWorkerAPI
,
serveWorkerAPI
M
)
import
Gargantext.Core.NodeStory.Types
(
HasNodeStory
)
import
Gargantext.Core.Text.Ngrams
(
Ngrams
,
NgramsType
(
NgramsTerms
))
import
Gargantext.Core.Types.Main
(
ListType
(
..
))
...
...
@@ -47,13 +47,12 @@ import Gargantext.Database.Schema.Ngrams ( text2ngrams, NgramsId )
import
Gargantext.Database.Schema.Node
(
_node_parent_id
)
import
Gargantext.Database.Types
(
Indexed
(
..
))
import
Gargantext.Prelude
hiding
(
concat
,
toList
)
import
Gargantext.System.Logging
(
logLocM
,
MonadLogger
)
import
Gargantext.System.Logging
import
Gargantext.Utils.Jobs.Monad
(
MonadJobStatus
(
..
))
import
Prelude
qualified
import
Protolude
qualified
as
P
import
Servant
import
Servant.Server.Generic
(
AsServerT
)
import
Gargantext.System.Logging
(
LogLevel
(
..
))
getAPI
::
Named
.
GETAPI
(
AsServerT
(
GargM
Env
BackendInternalError
))
...
...
@@ -159,11 +158,12 @@ tsvAPI = tsvPostAsync
tsvPostAsync
::
Named
.
TSVAPI
(
AsServerT
(
GargM
Env
BackendInternalError
))
tsvPostAsync
=
Named
.
TSVAPI
{
updateListTSVEp
=
\
lId
->
serveWorkerAPIEJob
$
\
p
->
updateListTSVEp
=
\
lId
->
serveWorkerAPIM
$
\
p
->
do
$
(
logLocM
)
DEBUG
$
"Started to upload "
<>
(
_wtf_name
p
)
case
ngramsListFromTSVData
(
_wtf_data
p
)
of
Left
err
->
Left
$
InternalServerError
$
err500
{
errReasonPhrase
=
err
}
Right
ngramsList
->
Right
$
Jobs
.
JSONPost
{
_jp_list_id
=
lId
,
_jp_ngrams_list
=
ngramsList
}
Left
err
->
throwError
$
InternalServerError
$
err500
{
errReasonPhrase
=
err
}
Right
ngramsList
->
pure
$
Jobs
.
JSONPost
{
_jp_list_id
=
lId
,
_jp_ngrams_list
=
ngramsList
}
}
-- | Tries converting a text file into an 'NgramList', so that we can reuse the
...
...
@@ -181,7 +181,8 @@ ngramsListFromTSVData tsvData = case decodeTsv of
decodeTsv
=
Vec
.
catMaybes
<$>
Tsv
.
decodeWithP
tsvToNgramsTableMap
(
Tsv
.
defaultDecodeOptions
{
Tsv
.
decDelimiter
=
fromIntegral
(
P
.
ord
'
\t
'
)
})
Tsv
.
HasHeader
-- Don't use an header, make it lenient in case the 'forms' are missing.
Tsv
.
NoHeader
binaryData
-- | Converts a plain TSV 'Record' into an NgramsTableMap
...
...
@@ -189,6 +190,9 @@ tsvToNgramsTableMap :: Tsv.Record -> Tsv.Parser (Maybe NgramsTableMap)
tsvToNgramsTableMap
record
=
case
Vec
.
toList
record
of
(
map
P
.
decodeUtf8
->
[
status
,
label
,
forms
])
->
pure
$
Just
$
conv
status
label
forms
-- Garg #381: alias the forms to the empty text.
(
map
P
.
decodeUtf8
->
[
status
,
label
])
->
pure
$
Just
$
conv
status
label
mempty
-- WARNING: This silently ignores errors (#433)
_
->
pure
Nothing
...
...
src/Gargantext/API/Worker.hs
View file @
eca8f40d
...
...
@@ -32,10 +32,15 @@ data WorkerAPI contentType input mode = WorkerAPI
serveWorkerAPI
::
IsGargServer
env
err
m
=>
(
input
->
Job
)
->
WorkerAPI
contentType
input
(
AsServerT
m
)
serveWorkerAPI
f
=
WorkerAPI
{
workerAPIPost
}
serveWorkerAPI
f
=
serveWorkerAPIM
(
pure
.
f
)
serveWorkerAPIM
::
IsGargServer
env
err
m
=>
(
input
->
m
Job
)
->
WorkerAPI
contentType
input
(
AsServerT
m
)
serveWorkerAPIM
mkJob
=
WorkerAPI
{
workerAPIPost
}
where
workerAPIPost
i
=
do
let
job
=
f
i
job
<-
mkJob
i
logM
DEBUG
$
"[serveWorkerAPI] sending job "
<>
show
job
mId
<-
sendJob
job
pure
$
JobInfo
{
_ji_message_id
=
mId
...
...
src/Gargantext/Core/Config/Utils.hs
View file @
eca8f40d
...
...
@@ -16,37 +16,27 @@ module Gargantext.Core.Config.Utils (
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Prelude
-- import Network.URI (URI)
-- import Network.URI (parseURI)
import
Toml
import
Toml.Schema
import
Gargantext.Core.Config
import
System.Environment
(
lookupEnv
)
import
Gargantext.System.Logging.Types
(
parseLogLevel
)
import
qualified
Data.Text
as
T
readConfig
::
FromValue
a
=>
SettingsFile
->
IO
a
readConfig
::
SettingsFile
->
IO
GargConfig
readConfig
(
SettingsFile
fp
)
=
do
c
<-
readFile
fp
case
decode
c
of
Failure
err
->
panicTrace
(
"Error reading TOML file: "
<>
show
err
)
Success
_
r
->
return
r
-- _URI :: Toml.TomlBiMap URI Text
-- _URI = Toml.BiMap (Right . show) parseURI'
-- where
-- parseURI' :: Text -> Either Toml.TomlBiMapError URI
-- parseURI' t =
-- case parseURI (T.unpack t) of
-- Nothing -> Left $ Toml.ArbitraryError "Cannot parse URI"
-- Just u -> Right u
-- uriToml :: Toml.Key -> Toml.TomlCodec URI
-- uriToml = Toml.match (_URI >>> Toml._Text)
-- _Word16 :: Toml.TomlBiMap Word16 Toml.AnyValue
-- _Word16 = Toml._BoundedInteger >>> Toml._Integer
-- word16Toml :: Toml.Key -> Toml.TomlCodec Word16
-- word16Toml = Toml.match _Word16
Success
_
r
->
do
-- Ovverride the log level based on the GGTX_LOG_LEVEL (if set)
mLvl
<-
lookupEnv
"GGTX_LOG_LEVEL"
case
mLvl
of
Nothing
->
pure
r
Just
s
->
case
parseLogLevel
(
T
.
pack
s
)
of
Left
err
->
do
putStrLn
$
"unknown log level "
<>
s
<>
": "
<>
T
.
unpack
err
<>
" , ignoring GGTX_LOG_LEVEL"
pure
r
Right
lvl'
->
pure
$
r
&
gc_logging
.
lc_log_level
.~
lvl'
src/Gargantext/Core/Text/List/Formats/TSV.hs
View file @
eca8f40d
...
...
@@ -54,7 +54,9 @@ data TsvList = TsvList
instance
FromNamedRecord
TsvList
where
parseNamedRecord
r
=
TsvList
<$>
r
.:
"status"
<*>
r
.:
"label"
<*>
r
.:
"forms"
-- Issue #381: be lenient in the forms
-- field, if missing, default to the empty text.
<*>
(
fromMaybe
mempty
<$>
r
.:
"forms"
)
instance
ToNamedRecord
TsvList
where
toNamedRecord
(
TsvList
s
l
f
)
=
...
...
src/Gargantext/Core/Worker/Env.hs
View file @
eca8f40d
...
...
@@ -24,15 +24,13 @@ import Control.Lens.TH
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
import
Data.Maybe
(
fromJust
)
import
Data.Pool
qualified
as
Pool
import
Data.Text
qualified
as
T
import
Database.PostgreSQL.Simple
qualified
as
PSQL
import
Gargantext.API.Admin.EnvTypes
(
Mode
(
Dev
),
modeToLoggingLevels
)
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
,
noJobLog
)
import
Gargantext.API.Job
(
RemainingSteps
(
..
),
jobLogStart
,
jobLogProgress
,
jobLogFailures
,
jobLogComplete
,
addErrorEvent
,
jobLogFailTotal
,
jobLogFailTotalWithMessage
,
jobLogAddMore
)
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.Core.Notifications.CentralExchange
qualified
as
CE
import
Gargantext.Core.Notifications.CentralExchange.Types
qualified
as
CET
import
Gargantext.Core.Config
(
GargConfig
(
..
),
HasConfig
(
..
),
gc_logging
)
import
Gargantext.Core.Config
(
GargConfig
(
..
),
HasConfig
(
..
),
gc_logging
,
LogConfig
)
import
Gargantext.Core.Config.Mail
qualified
as
Mail
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
...
...
@@ -50,6 +48,7 @@ import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
import
GHC.IO.Exception
(
IOException
(
..
),
IOErrorType
(
OtherError
))
import
Prelude
qualified
import
System.Log.FastLogger
qualified
as
FL
import
Gargantext.System.Logging.Loggers
data
WorkerEnv
=
WorkerEnv
...
...
@@ -70,13 +69,14 @@ data WorkerJobState = WorkerJobState
withWorkerEnv
::
SettingsFile
->
(
WorkerEnv
->
IO
a
)
->
IO
a
withWorkerEnv
settingsFile
k
=
withLoggerIO
Dev
$
\
logger
->
do
env
<-
newWorkerEnv
logger
k
env
-- `finally` cleanEnv env
withWorkerEnv
settingsFile
k
=
do
cfg
<-
readConfig
settingsFile
withLoggerIO
(
cfg
^.
gc_logging
)
$
\
logger
->
do
env
<-
newWorkerEnv
logger
cfg
k
env
-- `finally` cleanEnv env
where
newWorkerEnv
logger
=
do
cfg
<-
readConfig
settingsFile
newWorkerEnv
logger
cfg
=
do
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
-- pool <- newPool $ _gc_database_config cfg
let
dbConfig
=
_gc_database_config
cfg
...
...
@@ -97,22 +97,14 @@ instance HasConfig WorkerEnv where
hasConfig
=
to
_w_env_config
instance
HasLogger
(
GargM
WorkerEnv
IOException
)
where
data
instance
Logger
(
GargM
WorkerEnv
IOException
)
=
GargWorkerLogger
{
w_logger_mode
::
Mode
,
w_logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
(
GargM
WorkerEnv
IOException
)
=
Mode
newtype
instance
Logger
(
GargM
WorkerEnv
IOException
)
=
GargWorkerLogger
{
_GargWorkerLogger
::
MonadicStdLogger
FL
.
LogStr
IO
}
type
instance
LogInitParams
(
GargM
WorkerEnv
IOException
)
=
LogConfig
type
instance
LogPayload
(
GargM
WorkerEnv
IOException
)
=
FL
.
LogStr
initLogger
mode
=
do
w_logger_set
<-
liftIO
$
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
pure
$
GargWorkerLogger
mode
w_logger_set
destroyLogger
(
GargWorkerLogger
{
..
})
=
liftIO
$
FL
.
rmLoggerSet
w_logger_set
logMsg
(
GargWorkerLogger
mode
logger_set
)
lvl
msg
=
do
let
pfx
=
"["
<>
show
lvl
<>
"] "
::
Text
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
)
initLogger
cfg
=
fmap
GargWorkerLogger
$
(
liftIO
$
monadicStdLogger
cfg
)
destroyLogger
=
liftIO
.
_msl_destroy
.
_GargWorkerLogger
logMsg
(
GargWorkerLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_msg
ioLogger
lvl
msg
logTxt
(
GargWorkerLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_txt
ioLogger
lvl
msg
instance
HasConnectionPool
WorkerEnv
where
connPool
=
to
_w_env_pool
...
...
@@ -182,29 +174,20 @@ newtype WorkerMonad a =
,
MonadFail
)
instance
HasLogger
WorkerMonad
where
data
instance
Logger
WorkerMonad
=
WorkerMonadLogger
{
wm_logger_mode
::
Mode
,
wm_logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
WorkerMonad
=
Mode
newtype
instance
Logger
WorkerMonad
=
WorkerMonadLogger
{
_WorkerMonadLogger
::
MonadicStdLogger
FL
.
LogStr
IO
}
type
instance
LogInitParams
WorkerMonad
=
LogConfig
type
instance
LogPayload
WorkerMonad
=
FL
.
LogStr
initLogger
mode
=
do
wm_logger_set
<-
liftIO
$
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
pure
$
WorkerMonadLogger
mode
wm_logger_set
destroyLogger
(
WorkerMonadLogger
{
..
})
=
liftIO
$
FL
.
rmLoggerSet
wm_logger_set
logMsg
(
WorkerMonadLogger
mode
logger_set
)
lvl
msg
=
do
let
pfx
=
"["
<>
show
lvl
<>
"] "
::
Text
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
)
initLogger
cfg
=
fmap
WorkerMonadLogger
$
(
liftIO
$
monadicStdLogger
cfg
)
destroyLogger
=
liftIO
.
_msl_destroy
.
_WorkerMonadLogger
logMsg
(
WorkerMonadLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_msg
ioLogger
lvl
msg
logTxt
(
WorkerMonadLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_txt
ioLogger
lvl
msg
instance
MonadLogger
WorkerMonad
where
getLogger
=
do
env
<-
ask
let
(
GargWorkerLogger
{
..
})
=
_w_env_logger
env
pure
$
WorkerMonadLogger
{
wm_logger_mode
=
w_logger_mode
,
wm_logger_set
=
w_logger_set
}
let
(
GargWorkerLogger
lgr
)
=
_w_env_logger
env
pure
$
WorkerMonadLogger
lgr
runWorkerMonad
::
WorkerEnv
->
WorkerMonad
a
->
IO
a
runWorkerMonad
env
m
=
do
...
...
src/Gargantext/System/Logging.hs
View file @
eca8f40d
...
...
@@ -13,17 +13,15 @@ module Gargantext.System.Logging (
)
where
import
Gargantext.System.Logging.Types
import
Gargantext.System.Logging.Loggers
import
Control.Exception.Safe
(
MonadMask
,
bracket
)
import
Control.Monad
(
when
)
import
Gargantext.Core.Config
(
LogConfig
(
..
))
import
Control.Monad.IO.Class
import
Control.Monad.Trans.Control
import
Data.Text
qualified
as
T
import
Data.Time.Clock
(
getCurrentTime
)
import
Language.Haskell.TH
hiding
(
Type
)
import
Language.Haskell.TH.Syntax
qualified
as
TH
import
Prelude
import
System.Environment
(
lookupEnv
)
-- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
...
...
@@ -86,25 +84,10 @@ withLoggerIO params act = bracket (initLogger params) destroyLogger act
-- | 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
LogLevel
data
instance
Logger
IO
=
IOLogger
{
_IOLogger
::
IOStdLogger
}
type
instance
LogInitParams
IO
=
LogConfig
type
instance
LogPayload
IO
=
String
initLogger
LogConfig
{
..
}
=
do
-- let the env var take precedence over the LogConfig one.
mLvl
<-
liftIO
$
lookupEnv
"GGTX_LOG_LEVEL"
lvl
<-
case
mLvl
of
Nothing
->
pure
_lc_log_level
Just
s
->
case
parseLogLevel
(
T
.
pack
s
)
of
Left
err
->
do
liftIO
$
putStrLn
$
"unknown log level "
<>
s
<>
": "
<>
T
.
unpack
err
<>
" , ignoring GGTX_LOG_LEVEL"
pure
$
_lc_log_level
Right
lvl'
->
pure
lvl'
pure
$
IOLogger
lvl
destroyLogger
_
=
pure
()
logMsg
(
IOLogger
minLvl
)
lvl
msg
=
do
t
<-
getCurrentTime
when
(
lvl
>=
minLvl
)
$
do
let
pfx
=
"["
<>
show
t
<>
"] ["
<>
show
lvl
<>
"] "
putStrLn
$
pfx
<>
msg
logTxt
lgr
lvl
msg
=
logMsg
lgr
lvl
(
T
.
unpack
msg
)
initLogger
cfg
=
fmap
IOLogger
$
(
liftIO
$
ioStdLogger
cfg
)
destroyLogger
=
liftIO
.
_iosl_destroy
.
_IOLogger
logMsg
(
IOLogger
ioLogger
)
=
_iosl_log_msg
ioLogger
logTxt
(
IOLogger
ioLogger
)
lvl
msg
=
liftIO
$
_iosl_log_txt
ioLogger
lvl
msg
src/Gargantext/System/Logging/Loggers.hs
0 → 100644
View file @
eca8f40d
{-| Canned loggers to avoid reinventing the wheel every time. -}
module
Gargantext.System.Logging.Loggers
(
ioStdLogger
,
IOStdLogger
-- opaque, you can't build it directly, use 'ioStdLogger'
,
_iosl_log_level
,
_iosl_destroy
,
_iosl_log_msg
,
_iosl_log_txt
,
monadicStdLogger
,
_msl_log_level
,
_msl_destroy
,
_msl_log_msg
,
_msl_log_txt
,
MonadicStdLogger
)
where
import
Control.Monad
import
Control.Monad.IO.Class
import
Data.Text
qualified
as
T
import
Data.Time
import
Gargantext.Core.Config
import
Gargantext.System.Logging.Types
import
Prelude
import
System.Log.FastLogger
qualified
as
FL
data
IOStdLogger
=
IOStdLogger
{
_iosl_log_level
::
LogLevel
,
_iosl_destroy
::
IO
()
,
_iosl_log_msg
::
LogLevel
->
String
->
IO
()
,
_iosl_log_txt
::
LogLevel
->
T
.
Text
->
IO
()
}
ioStdLogger
::
LogConfig
->
IO
IOStdLogger
ioStdLogger
LogConfig
{
..
}
=
do
let
minLvl
=
_lc_log_level
let
log_msg
lvl
msg
=
do
t
<-
getCurrentTime
when
(
lvl
>=
minLvl
)
$
do
let
pfx
=
"["
<>
show
t
<>
"] ["
<>
show
lvl
<>
"] "
putStrLn
$
pfx
<>
msg
pure
$
IOStdLogger
{
_iosl_log_level
=
minLvl
,
_iosl_destroy
=
pure
()
,
_iosl_log_msg
=
log_msg
,
_iosl_log_txt
=
\
lvl
msg
->
log_msg
lvl
(
T
.
unpack
msg
)
}
-- | A monadic standard logger powered by fast-logger underneath.
data
MonadicStdLogger
payload
m
=
MonadicStdLogger
{
_msl_log_level
::
LogLevel
,
_msl_loggers
::
[
FL
.
LoggerSet
]
,
_msl_destroy
::
m
()
,
_msl_log_msg
::
LogLevel
->
payload
->
m
()
,
_msl_log_txt
::
LogLevel
->
T
.
Text
->
m
()
}
monadicStdLogger
::
MonadIO
m
=>
LogConfig
->
IO
(
MonadicStdLogger
FL
.
LogStr
m
)
monadicStdLogger
LogConfig
{
..
}
=
do
let
minLvl
=
_lc_log_level
stdout_logger
<-
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
let
log_msg
lvl
msg
=
liftIO
$
do
t
<-
getCurrentTime
when
(
lvl
>=
minLvl
)
$
do
let
pfx
=
"["
<>
show
t
<>
"] ["
<>
show
lvl
<>
"] "
FL
.
pushLogStrLn
stdout_logger
$
FL
.
toLogStr
pfx
<>
msg
pure
$
MonadicStdLogger
{
_msl_log_level
=
minLvl
,
_msl_loggers
=
[
stdout_logger
]
,
_msl_destroy
=
liftIO
$
FL
.
rmLoggerSet
stdout_logger
,
_msl_log_msg
=
log_msg
,
_msl_log_txt
=
\
lvl
msg
->
log_msg
lvl
(
FL
.
toLogStr
$
T
.
unpack
msg
)
}
test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir.tsv
0 → 100644
View file @
eca8f40d
status label
map impact-point analysis
map Simulated Destructive Re-Entry Conditions
map Passive Space-Debris Trajectories
map error-proofing mechanisms
map on-orbit life extension
map tether-gripper mechanism
map Field-Programmable Gate Arrays (FPGA)
map self-repair modular robot
map space-debris impact
map self-repairing
map in-orbit servicing
map online self-repairing
map triple-module redundancy systems
map model-based system engineering
map low-thrust orbital transfer
map space-borne orbit debris surveillance
map atmospheric re-entry
map demisable tanks' re-entry
map non-cooperative spacecraft
map model-based approaches
map model-based methods
map impact-induced electrical anomalies
map Low-Cost Deorbit System
map tape-shaped tethers
map self-repair
map self-healing material
map vision-based navigation
map model-based process
test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir12.csv
0 → 100644
View file @
eca8f40d
status,label
map,impact-point analysis
map,Simulated Destructive Re-Entry Conditions
map,Passive Space-Debris Trajectories
map,error-proofing mechanisms
map,on-orbit life extension
map,tether-gripper mechanism
map,Field-Programmable Gate Arrays (FPGA)
map,self-repair modular robot
map,space-debris impact
map,self-repairing
map,in-orbit servicing
map,online self-repairing
map,triple-module redundancy systems
map,model-based system engineering
map,low-thrust orbital transfer
map,space-borne orbit debris surveillance
map,atmospheric re-entry
map,demisable tanks' re-entry
map,non-cooperative spacecraft
map,model-based approaches
map,model-based methods
map,impact-induced electrical anomalies
map,Low-Cost Deorbit System
map,tape-shaped tethers
map,self-repair
map,self-healing material
map,vision-based navigation
map,model-based process
test/Test/API/Private.hs
View file @
eca8f40d
...
...
@@ -23,6 +23,7 @@ import Test.API.Private.Move qualified as Move
import
Test.API.Private.Remote
qualified
as
Remote
import
Test.API.Private.Share
qualified
as
Share
import
Test.API.Private.Table
qualified
as
Table
import
Test.API.Private.List
qualified
as
List
import
Test.API.Routes
(
mkUrl
,
get_node
,
get_tree
)
import
Test.API.Setup
(
withTestDBAndPort
,
dbEnvSetup
,
SpecContext
(
..
))
import
Test.Hspec
...
...
@@ -114,3 +115,5 @@ tests = sequential $ do
Move
.
tests
describe
"Remote API"
$
do
Remote
.
tests
describe
"List API"
$
do
List
.
tests
test/Test/API/Private/List.hs
0 → 100644
View file @
eca8f40d
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module
Test.API.Private.List
(
tests
)
where
import
Data.Aeson.QQ
import
Data.Text.IO
qualified
as
TIO
import
Gargantext.API.Ngrams.List.Types
import
Gargantext.API.Ngrams.Types
qualified
as
APINgrams
import
Gargantext.API.Node.Corpus.New.Types
qualified
as
FType
import
Gargantext.Core.Config
import
Gargantext.Core.Types
import
Gargantext.Core.Types.Individu
import
Gargantext.Prelude
import
Paths_gargantext
import
Servant.Client.Streaming
import
Test.API.Prelude
(
newCorpusForUser
,
checkEither
)
import
Test.API.Routes
import
Test.API.Setup
import
Test.Database.Types
import
Test.Hspec
(
Spec
,
it
,
aroundAll
,
describe
,
sequential
)
import
Test.Hspec.Expectations
import
Test.Hspec.Wai.Internal
(
withApplication
)
import
Test.Utils
import
Fmt
tests
::
Spec
tests
=
sequential
$
aroundAll
withTestDBAndPort
$
do
describe
"Prelude"
$
do
it
"setup DB triggers"
$
\
SpecContext
{
..
}
->
do
setupEnvironment
_sctx_env
-- Let's create the Alice user.
void
$
createAliceAndBob
_sctx_env
describe
"Importing terms as TSV"
$
do
it
"[#381] should work (and return a non-empty list of ngrams"
$
\
(
SpecContext
testEnv
port
app
_
)
->
do
cId
<-
newCorpusForUser
testEnv
"alice"
let
log_cfg
=
(
test_config
testEnv
)
^.
gc_logging
withApplication
app
$
do
withValidLogin
port
"alice"
(
GargPassword
"alice"
)
$
\
clientEnv
token
->
do
([
listId
]
::
[
NodeId
])
<-
protectedJSON
token
"POST"
(
mkUrl
port
(
"/node/"
<>
build
cId
))
[
aesonQQ
|
{"pn_typename":"NodeList","pn_name":"Testing"}
|]
-- Upload the CSV doc
simpleNgrams
<-
liftIO
(
TIO
.
readFile
=<<
getDataFileName
"test-data/issue-381/Termes_A_Ajouter_T4SC_Intellixir.tsv"
)
let
params
=
WithTextFile
{
_wtf_filetype
=
FType
.
TSV
,
_wtf_data
=
simpleNgrams
,
_wtf_name
=
"simple.tsv"
}
ji
<-
checkEither
$
liftIO
$
runClientM
(
add_tsv_to_list
token
listId
params
)
clientEnv
_
<-
pollUntilWorkFinished
log_cfg
port
ji
-- Now check that we can retrieve the ngrams, and the ngrams list is not empty!
liftIO
$
do
eRes
<-
checkEither
$
runClientM
(
get_table_ngrams
token
cId
APINgrams
.
Terms
listId
50
Nothing
(
Just
MapTerm
)
Nothing
Nothing
Nothing
Nothing
)
clientEnv
let
(
APINgrams
.
NgramsTable
terms
)
=
APINgrams
.
_vc_data
eRes
length
terms
`
shouldSatisfy
`
(
>=
1
)
test/Test/API/Private/Remote.hs
View file @
eca8f40d
...
...
@@ -7,11 +7,11 @@ module Test.API.Private.Remote (
)
where
import
Control.Lens
import
Gargantext.API.Admin.EnvTypes
(
Mode
(
..
))
import
Gargantext.API.Errors
import
Gargantext.API
(
makeApp
)
import
Gargantext.API.Routes.Client
(
remoteExportClient
)
import
Gargantext.API.Routes.Named.Remote
(
RemoteExportRequest
(
..
))
import
Gargantext.Core.Config
import
Gargantext.Core.Types.Individu
import
Gargantext.Core.Types
(
NodeId
(
UnsafeMkNodeId
))
import
Gargantext.Prelude
...
...
@@ -32,10 +32,10 @@ withTwoServerInstances :: (SpecContext (TestEnv,Wai.Application,Warp.Port) -> IO
withTwoServerInstances
action
=
withTestDB
$
\
testEnv1
->
do
withTestDB
$
\
testEnv2
->
do
garg1App
<-
withLoggerIO
Mock
$
\
ioLogger
->
do
garg1App
<-
withLoggerIO
(
log_cfg
testEnv1
)
$
\
ioLogger
->
do
env
<-
newTestEnv
testEnv1
ioLogger
server1Port
makeApp
env
garg2App
<-
withLoggerIO
Mock
$
\
ioLogger
->
do
garg2App
<-
withLoggerIO
(
log_cfg
testEnv2
)
$
\
ioLogger
->
do
env
<-
newTestEnv
testEnv2
ioLogger
server2Port
makeApp
env
...
...
@@ -45,6 +45,7 @@ withTwoServerInstances action =
where
server1Port
=
8008
server2Port
=
9008
log_cfg
te
=
(
test_config
te
)
^.
gc_logging
tests
::
Spec
tests
=
sequential
$
aroundAll
withTwoServerInstances
$
do
...
...
test/Test/API/Setup.hs
View file @
eca8f40d
...
...
@@ -20,7 +20,7 @@ import Control.Monad.Reader
import
Data.ByteString.Lazy.Char8
qualified
as
C8L
import
Data.Cache
qualified
as
InMemory
import
Data.Streaming.Network
(
bindPortTCP
)
import
Gargantext.API.Admin.EnvTypes
(
Mode
(
Mock
),
Env
(
..
),
env_dispatcher
)
import
Gargantext.API.Admin.EnvTypes
(
Env
(
..
),
env_dispatcher
)
import
Gargantext.API.Errors.Types
import
Gargantext.API
(
makeApp
)
import
Gargantext.API.Prelude
...
...
@@ -112,7 +112,7 @@ nc = NotificationsConfig { _nc_central_exchange_bind = "tcp://*:15560"
withTestDBAndPort
::
(
SpecContext
()
->
IO
()
)
->
IO
()
withTestDBAndPort
action
=
withTestDB
$
\
testEnv
->
do
withNotifications
(
cfg
testEnv
)
$
\
dispatcher
->
do
withLoggerIO
Mock
$
\
ioLogger
->
do
withLoggerIO
(
log_cfg
testEnv
)
$
\
ioLogger
->
do
env
<-
newTestEnv
testEnv
ioLogger
8080
<&>
env_dispatcher
.~
dispatcher
app
<-
makeApp
env
...
...
@@ -147,11 +147,11 @@ withTestDBAndPort action = withTestDB $ \testEnv -> do
withBackendServerAndProxy
::
(((
TestEnv
,
Warp
.
Port
,
Warp
.
Port
))
->
IO
()
)
->
IO
()
withBackendServerAndProxy
action
=
withTestDB
$
\
testEnv
->
do
gargApp
<-
withLoggerIO
Mock
$
\
ioLogger
->
do
gargApp
<-
withLoggerIO
(
log_cfg
testEnv
)
$
\
ioLogger
->
do
env
<-
newTestEnv
testEnv
ioLogger
8080
makeApp
env
proxyCache
<-
InMemory
.
newCache
Nothing
proxyApp
<-
withLoggerIO
Mock
$
\
ioLogger
->
do
proxyApp
<-
withLoggerIO
(
log_cfg
testEnv
)
$
\
ioLogger
->
do
env
<-
newTestEnv
testEnv
ioLogger
8080
pure
$
microServicesProxyApp
proxyCache
env
...
...
@@ -160,6 +160,8 @@ withBackendServerAndProxy action =
action
(
testEnv
,
serverPort
,
proxyPort
)
where
proxyPort
=
8090
cfg
te
=
test_config
te
log_cfg
te
=
(
cfg
te
)
^.
gc_logging
setupEnvironment
::
TestEnv
->
IO
()
setupEnvironment
env
=
flip
runReaderT
env
$
runTestMonad
$
do
...
...
test/Test/Database/Setup.hs
View file @
eca8f40d
...
...
@@ -18,7 +18,6 @@ import Database.PostgreSQL.Simple qualified as PG
import
Database.PostgreSQL.Simple.Options
qualified
as
Client
import
Database.PostgreSQL.Simple.Options
qualified
as
Opts
import
Database.Postgres.Temp
qualified
as
Tmp
import
Gargantext.API.Admin.EnvTypes
(
Mode
(
Mock
))
import
Gargantext.Core.Config
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.Config.Utils
(
readConfig
)
...
...
@@ -88,6 +87,7 @@ setup = do
<&>
(
gc_worker
.
wsDatabase
.~
(
connInfo
{
PG
.
connectDatabase
=
"pgmq_test"
}))
-- putText $ "[setup] database: " <> show (gargConfig ^. gc_database_config)
-- putText $ "[setup] worker db: " <> show (gargConfig ^. gc_worker . wsDatabase)
let
log_cfg
=
gargConfig
^.
gc_logging
let
idleTime
=
60.0
let
maxResources
=
2
let
poolConfig
=
defaultPoolConfig
(
PG
.
connectPostgreSQL
(
Tmp
.
toConnectionString
db
))
...
...
@@ -98,7 +98,7 @@ setup = do
bootstrapDB
db
pool
gargConfig
ugen
<-
emptyCounter
test_nodeStory
<-
fromDBNodeStoryEnv
pool
withLoggerIO
Mock
$
\
logger
->
do
withLoggerIO
log_cfg
$
\
logger
->
do
let
wPoolConfig
=
defaultPoolConfig
(
PG
.
connectPostgreSQL
(
Tmp
.
toConnectionString
db
))
PG
.
close
...
...
@@ -107,7 +107,7 @@ setup = do
wPool
<-
newPool
(
setNumStripes
(
Just
2
)
wPoolConfig
)
wNodeStory
<-
fromDBNodeStoryEnv
wPool
_w_env_job_state
<-
newTVarIO
Nothing
withLoggerIO
Mock
$
\
wioLogger
->
do
withLoggerIO
log_cfg
$
\
wioLogger
->
do
let
wEnv
=
WorkerEnv
{
_w_env_config
=
gargConfig
,
_w_env_logger
=
wioLogger
,
_w_env_pool
=
wPool
...
...
test/Test/Database/Types.hs
View file @
eca8f40d
...
...
@@ -22,11 +22,9 @@ import Control.Monad.Trans.Control
import
Data.IORef
import
Data.Map
qualified
as
Map
import
Data.Pool
import
Data.Text
qualified
as
T
import
Database.PostgreSQL.Simple
qualified
as
PG
import
Database.Postgres.Temp
qualified
as
Tmp
import
Gargantext
hiding
(
to
)
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.Prelude
...
...
@@ -36,6 +34,7 @@ import Gargantext.Core.Mail.Types (HasMail(..))
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
))
import
Gargantext.Core.NodeStory
import
Gargantext.System.Logging
(
HasLogger
(
..
),
Logger
,
MonadLogger
(
..
))
import
Gargantext.System.Logging.Loggers
import
Gargantext.Utils.Jobs.Monad
(
MonadJobStatus
(
..
))
import
Network.URI
(
parseURI
)
import
Prelude
qualified
...
...
@@ -132,22 +131,11 @@ instance MonadLogger (GargM TestEnv BackendInternalError) where
getLogger
=
asks
test_logger
instance
HasLogger
(
GargM
TestEnv
BackendInternalError
)
where
data
instance
Logger
(
GargM
TestEnv
BackendInternalError
)
=
GargTestLogger
{
test_logger_mode
::
Mode
,
test_logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
(
GargM
TestEnv
BackendInternalError
)
=
Mode
newtype
instance
Logger
(
GargM
TestEnv
BackendInternalError
)
=
GargTestLogger
{
_GargTestLogger
::
MonadicStdLogger
FL
.
LogStr
IO
}
type
instance
LogInitParams
(
GargM
TestEnv
BackendInternalError
)
=
LogConfig
type
instance
LogPayload
(
GargM
TestEnv
BackendInternalError
)
=
FL
.
LogStr
initLogger
mode
=
do
test_logger_set
<-
liftIO
$
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
pure
$
GargTestLogger
mode
test_logger_set
destroyLogger
GargTestLogger
{
..
}
=
liftIO
$
FL
.
rmLoggerSet
test_logger_set
logMsg
(
GargTestLogger
mode
logger_set
)
lvl
msg
=
do
cfg
<-
view
hasConfig
let
minLvl
=
cfg
^.
gc_logging
.
lc_log_level
when
(
lvl
>=
minLvl
)
$
do
let
pfx
=
"["
<>
show
lvl
<>
"] "
::
Text
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
)
initLogger
cfg
=
fmap
GargTestLogger
$
(
liftIO
$
monadicStdLogger
cfg
)
destroyLogger
=
liftIO
.
_msl_destroy
.
_GargTestLogger
logMsg
(
GargTestLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_msg
ioLogger
lvl
msg
logTxt
(
GargTestLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_txt
ioLogger
lvl
msg
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