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
151
Issues
151
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
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:
...
@@ -54,6 +54,8 @@ data-files:
test-data/stemming/lancaster.txt
test-data/stemming/lancaster.txt
test-data/test_config.ini
test-data/test_config.ini
test-data/test_config.toml
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
.clippy.dhall
-- common options
-- common options
...
@@ -309,6 +311,7 @@ library
...
@@ -309,6 +311,7 @@ library
Gargantext.Orphans.Accelerate
Gargantext.Orphans.Accelerate
Gargantext.Orphans.OpenAPI
Gargantext.Orphans.OpenAPI
Gargantext.System.Logging
Gargantext.System.Logging
Gargantext.System.Logging.Loggers
Gargantext.System.Logging.Types
Gargantext.System.Logging.Types
Gargantext.Utils.Dict
Gargantext.Utils.Dict
Gargantext.Utils.Jobs.Error
Gargantext.Utils.Jobs.Error
...
@@ -803,6 +806,7 @@ test-suite garg-test-tasty
...
@@ -803,6 +806,7 @@ test-suite garg-test-tasty
other-modules:
other-modules:
CLI.Phylo.Common
CLI.Phylo.Common
Paths_gargantext
Paths_gargantext
Test.API.Private.List
Test.API.Private.Move
Test.API.Private.Move
Test.API.Private.Remote
Test.API.Private.Remote
Test.API.Private.Share
Test.API.Private.Share
...
@@ -877,6 +881,7 @@ test-suite garg-test-hspec
...
@@ -877,6 +881,7 @@ test-suite garg-test-hspec
Test.API.GraphQL
Test.API.GraphQL
Test.API.Notifications
Test.API.Notifications
Test.API.Private
Test.API.Private
Test.API.Private.List
Test.API.Private.Move
Test.API.Private.Move
Test.API.Private.Remote
Test.API.Private.Remote
Test.API.Private.Share
Test.API.Private.Share
...
...
hie.yaml
View file @
eca8f40d
...
@@ -68,9 +68,3 @@ cradle:
...
@@ -68,9 +68,3 @@ cradle:
-
path
:
"
./test"
-
path
:
"
./test"
component
:
"
gargantext:test:garg-test-hspec"
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
...
@@ -70,29 +70,30 @@ import System.Cron.Schedule qualified as Cron
-- | startGargantext takes as parameters port number and Toml file.
-- | startGargantext takes as parameters port number and Toml file.
startGargantext
::
Mode
->
PortNumber
->
SettingsFile
->
IO
()
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
config
<-
readConfig
sf
<&>
(
gc_frontend_config
.
fc_appPort
)
.~
port
when
(
port
/=
config
^.
gc_frontend_config
.
fc_appPort
)
$
withLoggerIO
(
config
^.
gc_logging
)
$
\
logger
->
do
panicTrace
"TODO: conflicting settings of port"
when
(
port
/=
config
^.
gc_frontend_config
.
fc_appPort
)
$
withNotifications
config
$
\
dispatcher
->
do
panicTrace
"TODO: conflicting settings of port"
env
<-
newEnv
logger
config
dispatcher
withNotifications
config
$
\
dispatcher
->
do
let
fc
=
env
^.
env_config
.
gc_frontend_config
env
<-
newEnv
logger
config
dispatcher
let
proxyStatus
=
microServicesProxyStatus
fc
let
fc
=
env
^.
env_config
.
gc_frontend_config
runDbCheck
env
let
proxyStatus
=
microServicesProxyStatus
fc
startupInfo
config
port
proxyStatus
runDbCheck
env
app
<-
makeApp
env
startupInfo
config
port
proxyStatus
mid
<-
makeGargMiddleware
(
fc
^.
fc_cors
)
mode
app
<-
makeApp
env
periodicActions
<-
schedulePeriodicActions
env
mid
<-
makeGargMiddleware
(
fc
^.
fc_cors
)
mode
periodicActions
<-
schedulePeriodicActions
env
let
runServer
=
run
port
(
mid
app
)
`
finally
`
stopGargantext
periodicActions
case
proxyStatus
of
let
runServer
=
run
port
(
mid
app
)
`
finally
`
stopGargantext
periodicActions
PXY_disabled
case
proxyStatus
of
->
runServer
-- the proxy is disabled, do not spawn the application
PXY_disabled
PXY_enabled
proxyPort
->
runServer
-- the proxy is disabled, do not spawn the application
->
do
PXY_enabled
proxyPort
proxyCache
<-
InMemory
.
newCache
(
Just
oneHour
)
->
do
let
runProxy
=
run
proxyPort
(
mid
(
microServicesProxyApp
proxyCache
env
))
proxyCache
<-
InMemory
.
newCache
(
Just
oneHour
)
Async
.
race_
runServer
runProxy
let
runProxy
=
run
proxyPort
(
mid
(
microServicesProxyApp
proxyCache
env
))
Async
.
race_
runServer
runProxy
where
runDbCheck
env
=
do
where
runDbCheck
env
=
do
r
<-
runExceptT
(
runReaderT
DB
.
dbCheck
env
)
`
catch
`
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 (
...
@@ -38,12 +38,11 @@ module Gargantext.API.Admin.EnvTypes (
import
Control.Lens
(
to
,
view
)
import
Control.Lens
(
to
,
view
)
import
Data.List
((
\\
))
import
Data.List
((
\\
))
import
Data.Pool
(
Pool
)
import
Data.Pool
(
Pool
)
import
Data.Text
qualified
as
T
import
Database.PostgreSQL.Simple
(
Connection
)
import
Database.PostgreSQL.Simple
(
Connection
)
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
,
noJobLog
)
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
,
noJobLog
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Prelude
(
GargM
,
IsGargServer
)
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.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
),
nlpServerMap
)
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
),
nlpServerMap
)
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
...
@@ -58,6 +57,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
...
@@ -58,6 +57,7 @@ import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
import
Network.HTTP.Client
(
Manager
)
import
Network.HTTP.Client
(
Manager
)
import
Servant.Auth.Server
(
JWTSettings
)
import
Servant.Auth.Server
(
JWTSettings
)
import
System.Log.FastLogger
qualified
as
FL
import
System.Log.FastLogger
qualified
as
FL
import
Gargantext.System.Logging.Loggers
data
Mode
=
Dev
|
Mock
|
Prod
data
Mode
=
Dev
|
Mock
|
Prod
...
@@ -139,21 +139,13 @@ instance MonadLogger (GargM DevEnv BackendInternalError) where
...
@@ -139,21 +139,13 @@ instance MonadLogger (GargM DevEnv BackendInternalError) where
instance
HasLogger
(
GargM
DevEnv
BackendInternalError
)
where
instance
HasLogger
(
GargM
DevEnv
BackendInternalError
)
where
data
instance
Logger
(
GargM
DevEnv
BackendInternalError
)
=
data
instance
Logger
(
GargM
DevEnv
BackendInternalError
)
=
GargDevLogger
{
GargDevLogger
{
_GargDevLogger
::
MonadicStdLogger
FL
.
LogStr
IO
}
dev_logger_mode
::
Mode
type
instance
LogInitParams
(
GargM
DevEnv
BackendInternalError
)
=
LogConfig
,
dev_logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
(
GargM
DevEnv
BackendInternalError
)
=
Mode
type
instance
LogPayload
(
GargM
DevEnv
BackendInternalError
)
=
FL
.
LogStr
type
instance
LogPayload
(
GargM
DevEnv
BackendInternalError
)
=
FL
.
LogStr
initLogger
=
\
mode
->
do
initLogger
cfg
=
fmap
GargDevLogger
$
(
liftIO
$
monadicStdLogger
cfg
)
dev_logger_set
<-
liftIO
$
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
destroyLogger
=
liftIO
.
_msl_destroy
.
_GargDevLogger
pure
$
GargDevLogger
mode
dev_logger_set
logMsg
(
GargDevLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_msg
ioLogger
lvl
msg
destroyLogger
=
\
GargDevLogger
{
..
}
->
liftIO
$
FL
.
rmLoggerSet
dev_logger_set
logTxt
(
GargDevLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_txt
ioLogger
lvl
msg
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
)
data
DevEnv
=
DevEnv
data
DevEnv
=
DevEnv
{
_dev_env_config
::
!
GargConfig
{
_dev_env_config
::
!
GargConfig
...
@@ -225,25 +217,14 @@ instance HasNLPServer DevEnv where
...
@@ -225,25 +217,14 @@ instance HasNLPServer DevEnv where
instance
IsGargServer
Env
BackendInternalError
(
GargM
Env
BackendInternalError
)
instance
IsGargServer
Env
BackendInternalError
(
GargM
Env
BackendInternalError
)
instance
HasLogger
(
GargM
Env
BackendInternalError
)
where
instance
HasLogger
(
GargM
Env
BackendInternalError
)
where
data
instance
Logger
(
GargM
Env
BackendInternalError
)
=
newtype
instance
Logger
(
GargM
Env
BackendInternalError
)
=
GargLogger
{
GargLogger
{
_GargLogger
::
MonadicStdLogger
FL
.
LogStr
IO
}
logger_mode
::
Mode
type
instance
LogInitParams
(
GargM
Env
BackendInternalError
)
=
LogConfig
,
logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
(
GargM
Env
BackendInternalError
)
=
Mode
type
instance
LogPayload
(
GargM
Env
BackendInternalError
)
=
FL
.
LogStr
type
instance
LogPayload
(
GargM
Env
BackendInternalError
)
=
FL
.
LogStr
initLogger
mode
=
do
initLogger
cfg
=
fmap
GargLogger
$
(
liftIO
$
monadicStdLogger
cfg
)
logger_set
<-
liftIO
$
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
destroyLogger
=
liftIO
.
_msl_destroy
.
_GargLogger
pure
$
GargLogger
mode
logger_set
logMsg
(
GargLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_msg
ioLogger
lvl
msg
destroyLogger
(
GargLogger
{
..
})
=
liftIO
$
FL
.
rmLoggerSet
logger_set
logTxt
(
GargLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_txt
ioLogger
lvl
msg
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
)
instance
MonadLogger
(
GargM
Env
BackendInternalError
)
where
instance
MonadLogger
(
GargM
Env
BackendInternalError
)
where
getLogger
=
asks
_env_logger
getLogger
=
asks
_env_logger
src/Gargantext/API/Dev.hs
View file @
eca8f40d
...
@@ -16,11 +16,11 @@ import Control.Lens (view)
...
@@ -16,11 +16,11 @@ import Control.Lens (view)
import
Control.Monad
(
fail
)
import
Control.Monad
(
fail
)
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Database.PostgreSQL.Simple
qualified
as
PGS
import
Data.Pool
(
withResource
)
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.Admin.Settings
(
newPool
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
)
import
Gargantext.API.Prelude
(
GargM
)
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.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.NodeStory
(
fromDBNodeStoryEnv
)
import
Gargantext.Core.NodeStory
(
fromDBNodeStoryEnv
)
...
@@ -32,14 +32,14 @@ import Servant ( ServerError )
...
@@ -32,14 +32,14 @@ import Servant ( ServerError )
-------------------------------------------------------------------
-------------------------------------------------------------------
withDevEnv
::
SettingsFile
->
(
DevEnv
->
IO
a
)
->
IO
a
withDevEnv
::
SettingsFile
->
(
DevEnv
->
IO
a
)
->
IO
a
withDevEnv
settingsFile
k
=
withLoggerIO
Dev
$
\
logger
->
do
withDevEnv
settingsFile
k
=
do
env
<-
newDevEnv
logger
cfg
<-
readConfig
settingsFile
k
env
-- `finally` cleanEnv env
withLoggerIO
(
cfg
^.
gc_logging
)
$
\
logger
->
do
env
<-
newDevEnv
logger
cfg
k
env
-- `finally` cleanEnv env
where
where
newDevEnv
logger
=
do
newDevEnv
logger
cfg
=
do
cfg
<-
readConfig
settingsFile
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
pool
<-
newPool
(
_gc_database_config
cfg
)
pool
<-
newPool
(
_gc_database_config
cfg
)
nodeStory_env
<-
fromDBNodeStoryEnv
pool
nodeStory_env
<-
fromDBNodeStoryEnv
pool
manager
<-
newTlsManager
manager
<-
newTlsManager
...
...
src/Gargantext/API/Ngrams/List.hs
View file @
eca8f40d
...
@@ -21,21 +21,21 @@ import Data.ByteString.Lazy qualified as BSL
...
@@ -21,21 +21,21 @@ import Data.ByteString.Lazy qualified as BSL
import
Data.Csv
qualified
as
Tsv
import
Data.Csv
qualified
as
Tsv
import
Data.HashMap.Strict
(
HashMap
)
import
Data.HashMap.Strict
(
HashMap
)
import
Data.HashMap.Strict
qualified
as
HashMap
import
Data.HashMap.Strict
qualified
as
HashMap
import
Data.Map.Strict
qualified
as
Map
import
Data.Map.Strict
(
toList
)
import
Data.Map.Strict
(
toList
)
import
Data.Map.Strict
qualified
as
Map
import
Data.Set
qualified
as
Set
import
Data.Set
qualified
as
Set
import
Data.Text
(
concat
,
pack
,
splitOn
)
import
Data.Text
(
concat
,
pack
,
splitOn
)
import
Data.Vector
qualified
as
Vec
import
Data.Vector
(
Vector
)
import
Data.Vector
(
Vector
)
import
Data.Vector
qualified
as
Vec
import
Gargantext.API.Admin.EnvTypes
(
Env
)
import
Gargantext.API.Admin.EnvTypes
(
Env
)
import
Gargantext.API.Errors.Types
(
BackendInternalError
(
InternalServerError
))
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
(
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.Ngrams.Types
import
Gargantext.API.Prelude
(
GargM
,
serverError
,
HasServerError
)
import
Gargantext.API.Prelude
(
GargM
,
serverError
,
HasServerError
)
import
Gargantext.API.Routes.Named.List
qualified
as
Named
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.NodeStory.Types
(
HasNodeStory
)
import
Gargantext.Core.Text.Ngrams
(
Ngrams
,
NgramsType
(
NgramsTerms
))
import
Gargantext.Core.Text.Ngrams
(
Ngrams
,
NgramsType
(
NgramsTerms
))
import
Gargantext.Core.Types.Main
(
ListType
(
..
))
import
Gargantext.Core.Types.Main
(
ListType
(
..
))
...
@@ -47,13 +47,12 @@ import Gargantext.Database.Schema.Ngrams ( text2ngrams, NgramsId )
...
@@ -47,13 +47,12 @@ import Gargantext.Database.Schema.Ngrams ( text2ngrams, NgramsId )
import
Gargantext.Database.Schema.Node
(
_node_parent_id
)
import
Gargantext.Database.Schema.Node
(
_node_parent_id
)
import
Gargantext.Database.Types
(
Indexed
(
..
))
import
Gargantext.Database.Types
(
Indexed
(
..
))
import
Gargantext.Prelude
hiding
(
concat
,
toList
)
import
Gargantext.Prelude
hiding
(
concat
,
toList
)
import
Gargantext.System.Logging
(
logLocM
,
MonadLogger
)
import
Gargantext.System.Logging
import
Gargantext.Utils.Jobs.Monad
(
MonadJobStatus
(
..
))
import
Gargantext.Utils.Jobs.Monad
(
MonadJobStatus
(
..
))
import
Prelude
qualified
import
Prelude
qualified
import
Protolude
qualified
as
P
import
Protolude
qualified
as
P
import
Servant
import
Servant
import
Servant.Server.Generic
(
AsServerT
)
import
Servant.Server.Generic
(
AsServerT
)
import
Gargantext.System.Logging
(
LogLevel
(
..
))
getAPI
::
Named
.
GETAPI
(
AsServerT
(
GargM
Env
BackendInternalError
))
getAPI
::
Named
.
GETAPI
(
AsServerT
(
GargM
Env
BackendInternalError
))
...
@@ -159,11 +158,12 @@ tsvAPI = tsvPostAsync
...
@@ -159,11 +158,12 @@ tsvAPI = tsvPostAsync
tsvPostAsync
::
Named
.
TSVAPI
(
AsServerT
(
GargM
Env
BackendInternalError
))
tsvPostAsync
::
Named
.
TSVAPI
(
AsServerT
(
GargM
Env
BackendInternalError
))
tsvPostAsync
=
tsvPostAsync
=
Named
.
TSVAPI
{
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
case
ngramsListFromTSVData
(
_wtf_data
p
)
of
Left
err
->
Left
$
InternalServerError
$
err500
{
errReasonPhrase
=
err
}
Left
err
->
throwError
$
InternalServerError
$
err500
{
errReasonPhrase
=
err
}
Right
ngramsList
->
Right
$
Jobs
.
JSONPost
{
_jp_list_id
=
lId
Right
ngramsList
->
pure
$
Jobs
.
JSONPost
{
_jp_list_id
=
lId
,
_jp_ngrams_list
=
ngramsList
}
,
_jp_ngrams_list
=
ngramsList
}
}
}
-- | Tries converting a text file into an 'NgramList', so that we can reuse the
-- | Tries converting a text file into an 'NgramList', so that we can reuse the
...
@@ -181,7 +181,8 @@ ngramsListFromTSVData tsvData = case decodeTsv of
...
@@ -181,7 +181,8 @@ ngramsListFromTSVData tsvData = case decodeTsv of
decodeTsv
=
Vec
.
catMaybes
<$>
decodeTsv
=
Vec
.
catMaybes
<$>
Tsv
.
decodeWithP
tsvToNgramsTableMap
Tsv
.
decodeWithP
tsvToNgramsTableMap
(
Tsv
.
defaultDecodeOptions
{
Tsv
.
decDelimiter
=
fromIntegral
(
P
.
ord
'
\t
'
)
})
(
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
binaryData
-- | Converts a plain TSV 'Record' into an NgramsTableMap
-- | Converts a plain TSV 'Record' into an NgramsTableMap
...
@@ -189,6 +190,9 @@ tsvToNgramsTableMap :: Tsv.Record -> Tsv.Parser (Maybe NgramsTableMap)
...
@@ -189,6 +190,9 @@ tsvToNgramsTableMap :: Tsv.Record -> Tsv.Parser (Maybe NgramsTableMap)
tsvToNgramsTableMap
record
=
case
Vec
.
toList
record
of
tsvToNgramsTableMap
record
=
case
Vec
.
toList
record
of
(
map
P
.
decodeUtf8
->
[
status
,
label
,
forms
])
(
map
P
.
decodeUtf8
->
[
status
,
label
,
forms
])
->
pure
$
Just
$
conv
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)
-- WARNING: This silently ignores errors (#433)
_
->
pure
Nothing
_
->
pure
Nothing
...
...
src/Gargantext/API/Worker.hs
View file @
eca8f40d
...
@@ -32,10 +32,15 @@ data WorkerAPI contentType input mode = WorkerAPI
...
@@ -32,10 +32,15 @@ data WorkerAPI contentType input mode = WorkerAPI
serveWorkerAPI
::
IsGargServer
env
err
m
serveWorkerAPI
::
IsGargServer
env
err
m
=>
(
input
->
Job
)
=>
(
input
->
Job
)
->
WorkerAPI
contentType
input
(
AsServerT
m
)
->
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
where
workerAPIPost
i
=
do
workerAPIPost
i
=
do
let
job
=
f
i
job
<-
mkJob
i
logM
DEBUG
$
"[serveWorkerAPI] sending job "
<>
show
job
logM
DEBUG
$
"[serveWorkerAPI] sending job "
<>
show
job
mId
<-
sendJob
job
mId
<-
sendJob
job
pure
$
JobInfo
{
_ji_message_id
=
mId
pure
$
JobInfo
{
_ji_message_id
=
mId
...
...
src/Gargantext/Core/Config/Utils.hs
View file @
eca8f40d
...
@@ -16,37 +16,27 @@ module Gargantext.Core.Config.Utils (
...
@@ -16,37 +16,27 @@ module Gargantext.Core.Config.Utils (
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude
-- import Network.URI (URI)
-- import Network.URI (parseURI)
import
Toml
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
readConfig
(
SettingsFile
fp
)
=
do
c
<-
readFile
fp
c
<-
readFile
fp
case
decode
c
of
case
decode
c
of
Failure
err
->
panicTrace
(
"Error reading TOML file: "
<>
show
err
)
Failure
err
->
panicTrace
(
"Error reading TOML file: "
<>
show
err
)
Success
_
r
->
return
r
Success
_
r
->
do
-- Ovverride the log level based on the GGTX_LOG_LEVEL (if set)
mLvl
<-
lookupEnv
"GGTX_LOG_LEVEL"
-- _URI :: Toml.TomlBiMap URI Text
case
mLvl
of
-- _URI = Toml.BiMap (Right . show) parseURI'
Nothing
->
pure
r
-- where
Just
s
->
-- parseURI' :: Text -> Either Toml.TomlBiMapError URI
case
parseLogLevel
(
T
.
pack
s
)
of
-- parseURI' t =
Left
err
->
do
-- case parseURI (T.unpack t) of
putStrLn
$
"unknown log level "
<>
s
<>
": "
<>
T
.
unpack
err
<>
" , ignoring GGTX_LOG_LEVEL"
-- Nothing -> Left $ Toml.ArbitraryError "Cannot parse URI"
pure
r
-- Just u -> Right u
Right
lvl'
->
pure
$
r
&
gc_logging
.
lc_log_level
.~
lvl'
-- 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
src/Gargantext/Core/Text/List/Formats/TSV.hs
View file @
eca8f40d
...
@@ -54,7 +54,9 @@ data TsvList = TsvList
...
@@ -54,7 +54,9 @@ data TsvList = TsvList
instance
FromNamedRecord
TsvList
where
instance
FromNamedRecord
TsvList
where
parseNamedRecord
r
=
TsvList
<$>
r
.:
"status"
parseNamedRecord
r
=
TsvList
<$>
r
.:
"status"
<*>
r
.:
"label"
<*>
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
instance
ToNamedRecord
TsvList
where
toNamedRecord
(
TsvList
s
l
f
)
=
toNamedRecord
(
TsvList
s
l
f
)
=
...
...
src/Gargantext/Core/Worker/Env.hs
View file @
eca8f40d
...
@@ -24,15 +24,13 @@ import Control.Lens.TH
...
@@ -24,15 +24,13 @@ import Control.Lens.TH
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
import
Data.Maybe
(
fromJust
)
import
Data.Maybe
(
fromJust
)
import
Data.Pool
qualified
as
Pool
import
Data.Pool
qualified
as
Pool
import
Data.Text
qualified
as
T
import
Database.PostgreSQL.Simple
qualified
as
PSQL
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.Admin.Orchestrator.Types
(
JobLog
,
noJobLog
)
import
Gargantext.API.Job
(
RemainingSteps
(
..
),
jobLogStart
,
jobLogProgress
,
jobLogFailures
,
jobLogComplete
,
addErrorEvent
,
jobLogFailTotal
,
jobLogFailTotalWithMessage
,
jobLogAddMore
)
import
Gargantext.API.Job
(
RemainingSteps
(
..
),
jobLogStart
,
jobLogProgress
,
jobLogFailures
,
jobLogComplete
,
addErrorEvent
,
jobLogFailTotal
,
jobLogFailTotalWithMessage
,
jobLogAddMore
)
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.Core.Notifications.CentralExchange
qualified
as
CE
import
Gargantext.Core.Notifications.CentralExchange
qualified
as
CE
import
Gargantext.Core.Notifications.CentralExchange.Types
qualified
as
CET
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.Mail
qualified
as
Mail
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
...
@@ -50,6 +48,7 @@ import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
...
@@ -50,6 +48,7 @@ import Gargantext.Utils.Jobs.Monad ( MonadJobStatus(..), JobHandle )
import
GHC.IO.Exception
(
IOException
(
..
),
IOErrorType
(
OtherError
))
import
GHC.IO.Exception
(
IOException
(
..
),
IOErrorType
(
OtherError
))
import
Prelude
qualified
import
Prelude
qualified
import
System.Log.FastLogger
qualified
as
FL
import
System.Log.FastLogger
qualified
as
FL
import
Gargantext.System.Logging.Loggers
data
WorkerEnv
=
WorkerEnv
data
WorkerEnv
=
WorkerEnv
...
@@ -70,13 +69,14 @@ data WorkerJobState = WorkerJobState
...
@@ -70,13 +69,14 @@ data WorkerJobState = WorkerJobState
withWorkerEnv
::
SettingsFile
->
(
WorkerEnv
->
IO
a
)
->
IO
a
withWorkerEnv
::
SettingsFile
->
(
WorkerEnv
->
IO
a
)
->
IO
a
withWorkerEnv
settingsFile
k
=
withLoggerIO
Dev
$
\
logger
->
do
withWorkerEnv
settingsFile
k
=
do
env
<-
newWorkerEnv
logger
cfg
<-
readConfig
settingsFile
k
env
-- `finally` cleanEnv env
withLoggerIO
(
cfg
^.
gc_logging
)
$
\
logger
->
do
env
<-
newWorkerEnv
logger
cfg
k
env
-- `finally` cleanEnv env
where
where
newWorkerEnv
logger
=
do
newWorkerEnv
logger
cfg
=
do
cfg
<-
readConfig
settingsFile
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
-- pool <- newPool $ _gc_database_config cfg
-- pool <- newPool $ _gc_database_config cfg
let
dbConfig
=
_gc_database_config
cfg
let
dbConfig
=
_gc_database_config
cfg
...
@@ -97,22 +97,14 @@ instance HasConfig WorkerEnv where
...
@@ -97,22 +97,14 @@ instance HasConfig WorkerEnv where
hasConfig
=
to
_w_env_config
hasConfig
=
to
_w_env_config
instance
HasLogger
(
GargM
WorkerEnv
IOException
)
where
instance
HasLogger
(
GargM
WorkerEnv
IOException
)
where
data
instance
Logger
(
GargM
WorkerEnv
IOException
)
=
newtype
instance
Logger
(
GargM
WorkerEnv
IOException
)
=
GargWorkerLogger
{
GargWorkerLogger
{
_GargWorkerLogger
::
MonadicStdLogger
FL
.
LogStr
IO
}
w_logger_mode
::
Mode
type
instance
LogInitParams
(
GargM
WorkerEnv
IOException
)
=
LogConfig
,
w_logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
(
GargM
WorkerEnv
IOException
)
=
Mode
type
instance
LogPayload
(
GargM
WorkerEnv
IOException
)
=
FL
.
LogStr
type
instance
LogPayload
(
GargM
WorkerEnv
IOException
)
=
FL
.
LogStr
initLogger
mode
=
do
initLogger
cfg
=
fmap
GargWorkerLogger
$
(
liftIO
$
monadicStdLogger
cfg
)
w_logger_set
<-
liftIO
$
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
destroyLogger
=
liftIO
.
_msl_destroy
.
_GargWorkerLogger
pure
$
GargWorkerLogger
mode
w_logger_set
logMsg
(
GargWorkerLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_msg
ioLogger
lvl
msg
destroyLogger
(
GargWorkerLogger
{
..
})
=
liftIO
$
FL
.
rmLoggerSet
w_logger_set
logTxt
(
GargWorkerLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_txt
ioLogger
lvl
msg
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
)
instance
HasConnectionPool
WorkerEnv
where
instance
HasConnectionPool
WorkerEnv
where
connPool
=
to
_w_env_pool
connPool
=
to
_w_env_pool
...
@@ -182,29 +174,20 @@ newtype WorkerMonad a =
...
@@ -182,29 +174,20 @@ newtype WorkerMonad a =
,
MonadFail
)
,
MonadFail
)
instance
HasLogger
WorkerMonad
where
instance
HasLogger
WorkerMonad
where
data
instance
Logger
WorkerMonad
=
newtype
instance
Logger
WorkerMonad
=
WorkerMonadLogger
{
WorkerMonadLogger
{
_WorkerMonadLogger
::
MonadicStdLogger
FL
.
LogStr
IO
}
wm_logger_mode
::
Mode
type
instance
LogInitParams
WorkerMonad
=
LogConfig
,
wm_logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
WorkerMonad
=
Mode
type
instance
LogPayload
WorkerMonad
=
FL
.
LogStr
type
instance
LogPayload
WorkerMonad
=
FL
.
LogStr
initLogger
mode
=
do
initLogger
cfg
=
fmap
WorkerMonadLogger
$
(
liftIO
$
monadicStdLogger
cfg
)
wm_logger_set
<-
liftIO
$
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
destroyLogger
=
liftIO
.
_msl_destroy
.
_WorkerMonadLogger
pure
$
WorkerMonadLogger
mode
wm_logger_set
logMsg
(
WorkerMonadLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_msg
ioLogger
lvl
msg
destroyLogger
(
WorkerMonadLogger
{
..
})
=
liftIO
$
FL
.
rmLoggerSet
wm_logger_set
logTxt
(
WorkerMonadLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_txt
ioLogger
lvl
msg
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
)
instance
MonadLogger
WorkerMonad
where
instance
MonadLogger
WorkerMonad
where
getLogger
=
do
getLogger
=
do
env
<-
ask
env
<-
ask
let
(
GargWorkerLogger
{
..
})
=
_w_env_logger
env
let
(
GargWorkerLogger
lgr
)
=
_w_env_logger
env
pure
$
WorkerMonadLogger
{
wm_logger_mode
=
w_logger_mode
pure
$
WorkerMonadLogger
lgr
,
wm_logger_set
=
w_logger_set
}
runWorkerMonad
::
WorkerEnv
->
WorkerMonad
a
->
IO
a
runWorkerMonad
::
WorkerEnv
->
WorkerMonad
a
->
IO
a
runWorkerMonad
env
m
=
do
runWorkerMonad
env
m
=
do
...
...
src/Gargantext/System/Logging.hs
View file @
eca8f40d
...
@@ -13,17 +13,15 @@ module Gargantext.System.Logging (
...
@@ -13,17 +13,15 @@ module Gargantext.System.Logging (
)
where
)
where
import
Gargantext.System.Logging.Types
import
Gargantext.System.Logging.Types
import
Gargantext.System.Logging.Loggers
import
Control.Exception.Safe
(
MonadMask
,
bracket
)
import
Control.Exception.Safe
(
MonadMask
,
bracket
)
import
Control.Monad
(
when
)
import
Gargantext.Core.Config
(
LogConfig
(
..
))
import
Gargantext.Core.Config
(
LogConfig
(
..
))
import
Control.Monad.IO.Class
import
Control.Monad.IO.Class
import
Control.Monad.Trans.Control
import
Control.Monad.Trans.Control
import
Data.Text
qualified
as
T
import
Data.Text
qualified
as
T
import
Data.Time.Clock
(
getCurrentTime
)
import
Language.Haskell.TH
hiding
(
Type
)
import
Language.Haskell.TH
hiding
(
Type
)
import
Language.Haskell.TH.Syntax
qualified
as
TH
import
Language.Haskell.TH.Syntax
qualified
as
TH
import
Prelude
import
Prelude
import
System.Environment
(
lookupEnv
)
-- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
-- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
...
@@ -86,25 +84,10 @@ withLoggerIO params act = bracket (initLogger params) destroyLogger act
...
@@ -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
-- | 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
-- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229
instance
HasLogger
IO
where
instance
HasLogger
IO
where
data
instance
Logger
IO
=
IOLogger
LogLevel
data
instance
Logger
IO
=
IOLogger
{
_IOLogger
::
IOStdLogger
}
type
instance
LogInitParams
IO
=
LogConfig
type
instance
LogInitParams
IO
=
LogConfig
type
instance
LogPayload
IO
=
String
type
instance
LogPayload
IO
=
String
initLogger
LogConfig
{
..
}
=
do
initLogger
cfg
=
fmap
IOLogger
$
(
liftIO
$
ioStdLogger
cfg
)
-- let the env var take precedence over the LogConfig one.
destroyLogger
=
liftIO
.
_iosl_destroy
.
_IOLogger
mLvl
<-
liftIO
$
lookupEnv
"GGTX_LOG_LEVEL"
logMsg
(
IOLogger
ioLogger
)
=
_iosl_log_msg
ioLogger
lvl
<-
case
mLvl
of
logTxt
(
IOLogger
ioLogger
)
lvl
msg
=
liftIO
$
_iosl_log_txt
ioLogger
lvl
msg
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
)
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
...
@@ -23,6 +23,7 @@ import Test.API.Private.Move qualified as Move
import
Test.API.Private.Remote
qualified
as
Remote
import
Test.API.Private.Remote
qualified
as
Remote
import
Test.API.Private.Share
qualified
as
Share
import
Test.API.Private.Share
qualified
as
Share
import
Test.API.Private.Table
qualified
as
Table
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.Routes
(
mkUrl
,
get_node
,
get_tree
)
import
Test.API.Setup
(
withTestDBAndPort
,
dbEnvSetup
,
SpecContext
(
..
))
import
Test.API.Setup
(
withTestDBAndPort
,
dbEnvSetup
,
SpecContext
(
..
))
import
Test.Hspec
import
Test.Hspec
...
@@ -114,3 +115,5 @@ tests = sequential $ do
...
@@ -114,3 +115,5 @@ tests = sequential $ do
Move
.
tests
Move
.
tests
describe
"Remote API"
$
do
describe
"Remote API"
$
do
Remote
.
tests
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 (
...
@@ -7,11 +7,11 @@ module Test.API.Private.Remote (
)
where
)
where
import
Control.Lens
import
Control.Lens
import
Gargantext.API.Admin.EnvTypes
(
Mode
(
..
))
import
Gargantext.API.Errors
import
Gargantext.API.Errors
import
Gargantext.API
(
makeApp
)
import
Gargantext.API
(
makeApp
)
import
Gargantext.API.Routes.Client
(
remoteExportClient
)
import
Gargantext.API.Routes.Client
(
remoteExportClient
)
import
Gargantext.API.Routes.Named.Remote
(
RemoteExportRequest
(
..
))
import
Gargantext.API.Routes.Named.Remote
(
RemoteExportRequest
(
..
))
import
Gargantext.Core.Config
import
Gargantext.Core.Types.Individu
import
Gargantext.Core.Types.Individu
import
Gargantext.Core.Types
(
NodeId
(
UnsafeMkNodeId
))
import
Gargantext.Core.Types
(
NodeId
(
UnsafeMkNodeId
))
import
Gargantext.Prelude
import
Gargantext.Prelude
...
@@ -32,10 +32,10 @@ withTwoServerInstances :: (SpecContext (TestEnv,Wai.Application,Warp.Port) -> IO
...
@@ -32,10 +32,10 @@ withTwoServerInstances :: (SpecContext (TestEnv,Wai.Application,Warp.Port) -> IO
withTwoServerInstances
action
=
withTwoServerInstances
action
=
withTestDB
$
\
testEnv1
->
do
withTestDB
$
\
testEnv1
->
do
withTestDB
$
\
testEnv2
->
do
withTestDB
$
\
testEnv2
->
do
garg1App
<-
withLoggerIO
Mock
$
\
ioLogger
->
do
garg1App
<-
withLoggerIO
(
log_cfg
testEnv1
)
$
\
ioLogger
->
do
env
<-
newTestEnv
testEnv1
ioLogger
server1Port
env
<-
newTestEnv
testEnv1
ioLogger
server1Port
makeApp
env
makeApp
env
garg2App
<-
withLoggerIO
Mock
$
\
ioLogger
->
do
garg2App
<-
withLoggerIO
(
log_cfg
testEnv2
)
$
\
ioLogger
->
do
env
<-
newTestEnv
testEnv2
ioLogger
server2Port
env
<-
newTestEnv
testEnv2
ioLogger
server2Port
makeApp
env
makeApp
env
...
@@ -45,6 +45,7 @@ withTwoServerInstances action =
...
@@ -45,6 +45,7 @@ withTwoServerInstances action =
where
where
server1Port
=
8008
server1Port
=
8008
server2Port
=
9008
server2Port
=
9008
log_cfg
te
=
(
test_config
te
)
^.
gc_logging
tests
::
Spec
tests
::
Spec
tests
=
sequential
$
aroundAll
withTwoServerInstances
$
do
tests
=
sequential
$
aroundAll
withTwoServerInstances
$
do
...
...
test/Test/API/Setup.hs
View file @
eca8f40d
...
@@ -20,7 +20,7 @@ import Control.Monad.Reader
...
@@ -20,7 +20,7 @@ import Control.Monad.Reader
import
Data.ByteString.Lazy.Char8
qualified
as
C8L
import
Data.ByteString.Lazy.Char8
qualified
as
C8L
import
Data.Cache
qualified
as
InMemory
import
Data.Cache
qualified
as
InMemory
import
Data.Streaming.Network
(
bindPortTCP
)
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.Errors.Types
import
Gargantext.API
(
makeApp
)
import
Gargantext.API
(
makeApp
)
import
Gargantext.API.Prelude
import
Gargantext.API.Prelude
...
@@ -112,7 +112,7 @@ nc = NotificationsConfig { _nc_central_exchange_bind = "tcp://*:15560"
...
@@ -112,7 +112,7 @@ nc = NotificationsConfig { _nc_central_exchange_bind = "tcp://*:15560"
withTestDBAndPort
::
(
SpecContext
()
->
IO
()
)
->
IO
()
withTestDBAndPort
::
(
SpecContext
()
->
IO
()
)
->
IO
()
withTestDBAndPort
action
=
withTestDB
$
\
testEnv
->
do
withTestDBAndPort
action
=
withTestDB
$
\
testEnv
->
do
withNotifications
(
cfg
testEnv
)
$
\
dispatcher
->
do
withNotifications
(
cfg
testEnv
)
$
\
dispatcher
->
do
withLoggerIO
Mock
$
\
ioLogger
->
do
withLoggerIO
(
log_cfg
testEnv
)
$
\
ioLogger
->
do
env
<-
newTestEnv
testEnv
ioLogger
8080
env
<-
newTestEnv
testEnv
ioLogger
8080
<&>
env_dispatcher
.~
dispatcher
<&>
env_dispatcher
.~
dispatcher
app
<-
makeApp
env
app
<-
makeApp
env
...
@@ -147,11 +147,11 @@ withTestDBAndPort action = withTestDB $ \testEnv -> do
...
@@ -147,11 +147,11 @@ withTestDBAndPort action = withTestDB $ \testEnv -> do
withBackendServerAndProxy
::
(((
TestEnv
,
Warp
.
Port
,
Warp
.
Port
))
->
IO
()
)
->
IO
()
withBackendServerAndProxy
::
(((
TestEnv
,
Warp
.
Port
,
Warp
.
Port
))
->
IO
()
)
->
IO
()
withBackendServerAndProxy
action
=
withBackendServerAndProxy
action
=
withTestDB
$
\
testEnv
->
do
withTestDB
$
\
testEnv
->
do
gargApp
<-
withLoggerIO
Mock
$
\
ioLogger
->
do
gargApp
<-
withLoggerIO
(
log_cfg
testEnv
)
$
\
ioLogger
->
do
env
<-
newTestEnv
testEnv
ioLogger
8080
env
<-
newTestEnv
testEnv
ioLogger
8080
makeApp
env
makeApp
env
proxyCache
<-
InMemory
.
newCache
Nothing
proxyCache
<-
InMemory
.
newCache
Nothing
proxyApp
<-
withLoggerIO
Mock
$
\
ioLogger
->
do
proxyApp
<-
withLoggerIO
(
log_cfg
testEnv
)
$
\
ioLogger
->
do
env
<-
newTestEnv
testEnv
ioLogger
8080
env
<-
newTestEnv
testEnv
ioLogger
8080
pure
$
microServicesProxyApp
proxyCache
env
pure
$
microServicesProxyApp
proxyCache
env
...
@@ -160,6 +160,8 @@ withBackendServerAndProxy action =
...
@@ -160,6 +160,8 @@ withBackendServerAndProxy action =
action
(
testEnv
,
serverPort
,
proxyPort
)
action
(
testEnv
,
serverPort
,
proxyPort
)
where
where
proxyPort
=
8090
proxyPort
=
8090
cfg
te
=
test_config
te
log_cfg
te
=
(
cfg
te
)
^.
gc_logging
setupEnvironment
::
TestEnv
->
IO
()
setupEnvironment
::
TestEnv
->
IO
()
setupEnvironment
env
=
flip
runReaderT
env
$
runTestMonad
$
do
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
...
@@ -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
Client
import
Database.PostgreSQL.Simple.Options
qualified
as
Opts
import
Database.PostgreSQL.Simple.Options
qualified
as
Opts
import
Database.Postgres.Temp
qualified
as
Tmp
import
Database.Postgres.Temp
qualified
as
Tmp
import
Gargantext.API.Admin.EnvTypes
(
Mode
(
Mock
))
import
Gargantext.Core.Config
import
Gargantext.Core.Config
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.Config.Utils
(
readConfig
)
...
@@ -88,6 +87,7 @@ setup = do
...
@@ -88,6 +87,7 @@ setup = do
<&>
(
gc_worker
.
wsDatabase
.~
(
connInfo
{
PG
.
connectDatabase
=
"pgmq_test"
}))
<&>
(
gc_worker
.
wsDatabase
.~
(
connInfo
{
PG
.
connectDatabase
=
"pgmq_test"
}))
-- putText $ "[setup] database: " <> show (gargConfig ^. gc_database_config)
-- putText $ "[setup] database: " <> show (gargConfig ^. gc_database_config)
-- putText $ "[setup] worker db: " <> show (gargConfig ^. gc_worker . wsDatabase)
-- putText $ "[setup] worker db: " <> show (gargConfig ^. gc_worker . wsDatabase)
let
log_cfg
=
gargConfig
^.
gc_logging
let
idleTime
=
60.0
let
idleTime
=
60.0
let
maxResources
=
2
let
maxResources
=
2
let
poolConfig
=
defaultPoolConfig
(
PG
.
connectPostgreSQL
(
Tmp
.
toConnectionString
db
))
let
poolConfig
=
defaultPoolConfig
(
PG
.
connectPostgreSQL
(
Tmp
.
toConnectionString
db
))
...
@@ -98,7 +98,7 @@ setup = do
...
@@ -98,7 +98,7 @@ setup = do
bootstrapDB
db
pool
gargConfig
bootstrapDB
db
pool
gargConfig
ugen
<-
emptyCounter
ugen
<-
emptyCounter
test_nodeStory
<-
fromDBNodeStoryEnv
pool
test_nodeStory
<-
fromDBNodeStoryEnv
pool
withLoggerIO
Mock
$
\
logger
->
do
withLoggerIO
log_cfg
$
\
logger
->
do
let
wPoolConfig
=
defaultPoolConfig
(
PG
.
connectPostgreSQL
(
Tmp
.
toConnectionString
db
))
let
wPoolConfig
=
defaultPoolConfig
(
PG
.
connectPostgreSQL
(
Tmp
.
toConnectionString
db
))
PG
.
close
PG
.
close
...
@@ -107,7 +107,7 @@ setup = do
...
@@ -107,7 +107,7 @@ setup = do
wPool
<-
newPool
(
setNumStripes
(
Just
2
)
wPoolConfig
)
wPool
<-
newPool
(
setNumStripes
(
Just
2
)
wPoolConfig
)
wNodeStory
<-
fromDBNodeStoryEnv
wPool
wNodeStory
<-
fromDBNodeStoryEnv
wPool
_w_env_job_state
<-
newTVarIO
Nothing
_w_env_job_state
<-
newTVarIO
Nothing
withLoggerIO
Mock
$
\
wioLogger
->
do
withLoggerIO
log_cfg
$
\
wioLogger
->
do
let
wEnv
=
WorkerEnv
{
_w_env_config
=
gargConfig
let
wEnv
=
WorkerEnv
{
_w_env_config
=
gargConfig
,
_w_env_logger
=
wioLogger
,
_w_env_logger
=
wioLogger
,
_w_env_pool
=
wPool
,
_w_env_pool
=
wPool
...
...
test/Test/Database/Types.hs
View file @
eca8f40d
...
@@ -22,11 +22,9 @@ import Control.Monad.Trans.Control
...
@@ -22,11 +22,9 @@ import Control.Monad.Trans.Control
import
Data.IORef
import
Data.IORef
import
Data.Map
qualified
as
Map
import
Data.Map
qualified
as
Map
import
Data.Pool
import
Data.Pool
import
Data.Text
qualified
as
T
import
Database.PostgreSQL.Simple
qualified
as
PG
import
Database.PostgreSQL.Simple
qualified
as
PG
import
Database.Postgres.Temp
qualified
as
Tmp
import
Database.Postgres.Temp
qualified
as
Tmp
import
Gargantext
hiding
(
to
)
import
Gargantext
hiding
(
to
)
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.Errors.Types
import
Gargantext.API.Prelude
import
Gargantext.API.Prelude
...
@@ -36,6 +34,7 @@ import Gargantext.Core.Mail.Types (HasMail(..))
...
@@ -36,6 +34,7 @@ import Gargantext.Core.Mail.Types (HasMail(..))
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
))
import
Gargantext.Core.NLP
(
HasNLPServer
(
..
))
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
import
Gargantext.System.Logging
(
HasLogger
(
..
),
Logger
,
MonadLogger
(
..
))
import
Gargantext.System.Logging
(
HasLogger
(
..
),
Logger
,
MonadLogger
(
..
))
import
Gargantext.System.Logging.Loggers
import
Gargantext.Utils.Jobs.Monad
(
MonadJobStatus
(
..
))
import
Gargantext.Utils.Jobs.Monad
(
MonadJobStatus
(
..
))
import
Network.URI
(
parseURI
)
import
Network.URI
(
parseURI
)
import
Prelude
qualified
import
Prelude
qualified
...
@@ -132,22 +131,11 @@ instance MonadLogger (GargM TestEnv BackendInternalError) where
...
@@ -132,22 +131,11 @@ instance MonadLogger (GargM TestEnv BackendInternalError) where
getLogger
=
asks
test_logger
getLogger
=
asks
test_logger
instance
HasLogger
(
GargM
TestEnv
BackendInternalError
)
where
instance
HasLogger
(
GargM
TestEnv
BackendInternalError
)
where
data
instance
Logger
(
GargM
TestEnv
BackendInternalError
)
=
newtype
instance
Logger
(
GargM
TestEnv
BackendInternalError
)
=
GargTestLogger
{
GargTestLogger
{
_GargTestLogger
::
MonadicStdLogger
FL
.
LogStr
IO
}
test_logger_mode
::
Mode
type
instance
LogInitParams
(
GargM
TestEnv
BackendInternalError
)
=
LogConfig
,
test_logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
(
GargM
TestEnv
BackendInternalError
)
=
Mode
type
instance
LogPayload
(
GargM
TestEnv
BackendInternalError
)
=
FL
.
LogStr
type
instance
LogPayload
(
GargM
TestEnv
BackendInternalError
)
=
FL
.
LogStr
initLogger
mode
=
do
initLogger
cfg
=
fmap
GargTestLogger
$
(
liftIO
$
monadicStdLogger
cfg
)
test_logger_set
<-
liftIO
$
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
destroyLogger
=
liftIO
.
_msl_destroy
.
_GargTestLogger
pure
$
GargTestLogger
mode
test_logger_set
logMsg
(
GargTestLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_msg
ioLogger
lvl
msg
destroyLogger
GargTestLogger
{
..
}
=
liftIO
$
FL
.
rmLoggerSet
test_logger_set
logTxt
(
GargTestLogger
ioLogger
)
lvl
msg
=
liftIO
$
_msl_log_txt
ioLogger
lvl
msg
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
)
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