Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
119
Issues
119
List
Board
Labels
Milestones
Merge Requests
7
Merge Requests
7
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
bb78d480
Commit
bb78d480
authored
Aug 23, 2023
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Plain Diff
Merge remote-tracking branch 'origin/adinapoli/issue-258-part-2' into dev
parents
e30d8cb7
0ce35337
Changes
15
Show whitespace changes
Inline
Side-by-side
Showing
15 changed files
with
270 additions
and
85 deletions
+270
-85
Main.hs
bin/gargantext-server/Main.hs
+20
-4
cabal.project
cabal.project
+1
-1
gargantext.cabal
gargantext.cabal
+1
-0
API.hs
src/Gargantext/API.hs
+6
-8
EnvTypes.hs
src/Gargantext/API/Admin/EnvTypes.hs
+73
-6
Settings.hs
src/Gargantext/API/Admin/Settings.hs
+4
-4
Dev.hs
src/Gargantext/API/Dev.hs
+5
-3
Job.hs
src/Gargantext/API/Job.hs
+4
-1
New.hs
src/Gargantext/API/Node/Corpus/New.hs
+11
-9
Prelude.hs
src/Gargantext/API/Prelude.hs
+2
-1
Flow.hs
src/Gargantext/Database/Action/Flow.hs
+20
-48
Types.hs
src/Gargantext/Database/Action/Flow/Types.hs
+2
-0
Add.hs
src/Gargantext/Database/Query/Table/Node/Document/Add.hs
+7
-0
Logging.hs
src/Gargantext/System/Logging.hs
+111
-0
Monad.hs
src/Gargantext/Utils/Jobs/Monad.hs
+3
-0
No files found.
bin/gargantext-server/Main.hs
View file @
bb78d480
...
@@ -16,15 +16,19 @@ Script to start gargantext with different modes (Dev, Prod, Mock).
...
@@ -16,15 +16,19 @@ Script to start gargantext with different modes (Dev, Prod, Mock).
{-# LANGUAGE Strict #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies #-}
module
Main
where
module
Main
where
import
Data.String
(
String
)
import
Data.Text
(
unpack
)
import
Data.Text
(
unpack
)
import
Data.Version
(
showVersion
)
import
Data.Version
(
showVersion
)
import
Gargantext.API
(
startGargantext
,
Mode
(
..
))
-- , startGargantextMock)
import
Gargantext.API
(
startGargantext
)
-- , startGargantextMock)
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.System.Logging
import
Options.Generic
import
Options.Generic
import
System.Exit
(
exitSuccess
)
import
System.Exit
(
exitSuccess
)
import
qualified
Paths_gargantext
as
PG
-- cabal magic build module
import
qualified
Paths_gargantext
as
PG
-- cabal magic build module
...
@@ -49,14 +53,26 @@ data MyOptions w =
...
@@ -49,14 +53,26 @@ data MyOptions w =
instance
ParseRecord
(
MyOptions
Wrapped
)
instance
ParseRecord
(
MyOptions
Wrapped
)
deriving
instance
Show
(
MyOptions
Unwrapped
)
deriving
instance
Show
(
MyOptions
Unwrapped
)
-- | A plain logger in the IO monad, waiting for more serious logging solutions like
-- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229
instance
HasLogger
IO
where
data
instance
Logger
IO
=
IOLogger
type
instance
LogInitParams
IO
=
()
type
instance
LogPayload
IO
=
String
initLogger
=
\
()
->
pure
IOLogger
destroyLogger
=
\
_
->
pure
()
logMsg
=
\
IOLogger
lvl
msg
->
let
pfx
=
"["
<>
show
lvl
<>
"] "
in
putStrLn
$
pfx
<>
msg
logTxt
lgr
lvl
msg
=
logMsg
lgr
lvl
(
unpack
msg
)
main
::
IO
()
main
::
IO
()
main
=
do
main
=
withLogger
()
$
\
ioLogger
->
do
MyOptions
myMode
myPort
myIniFile
myVersion
<-
unwrapRecord
MyOptions
myMode
myPort
myIniFile
myVersion
<-
unwrapRecord
"Gargantext server"
"Gargantext server"
---------------------------------------------------------------
---------------------------------------------------------------
if
myVersion
then
do
if
myVersion
then
do
putStrLn
$
"Version: "
<>
showVersion
PG
.
version
logMsg
ioLogger
INFO
$
"Version: "
<>
showVersion
PG
.
version
System
.
Exit
.
exitSuccess
System
.
Exit
.
exitSuccess
else
else
return
()
return
()
...
@@ -73,6 +89,6 @@ main = do
...
@@ -73,6 +89,6 @@ main = do
let
start
=
case
myMode
of
let
start
=
case
myMode
of
Mock
->
panic
"[ERROR] Mock mode unsupported"
Mock
->
panic
"[ERROR] Mock mode unsupported"
_
->
startGargantext
myMode
myPort'
(
unpack
myIniFile'
)
_
->
startGargantext
myMode
myPort'
(
unpack
myIniFile'
)
putStrLn
$
"Starting with "
<>
show
myMode
<>
" mode."
logMsg
ioLogger
INFO
$
"Starting with "
<>
show
myMode
<>
" mode."
start
start
---------------------------------------------------------------
---------------------------------------------------------------
cabal.project
View file @
bb78d480
...
@@ -79,7 +79,7 @@ source-repository-package
...
@@ -79,7 +79,7 @@ source-repository-package
source
-
repository
-
package
source
-
repository
-
package
type
:
git
type
:
git
location
:
https
://
gitlab
.
iscpif
.
fr
/
gargantext
/
crawlers
/
arxiv
-
api
.
git
location
:
https
://
gitlab
.
iscpif
.
fr
/
gargantext
/
crawlers
/
arxiv
-
api
.
git
tag
:
2
d7e5753cbbce248b860b571a0e9885415c846f7
tag
:
eb130c71fa17adaceed6ff66beefbccb13df51ba
source
-
repository
-
package
source
-
repository
-
package
type
:
git
type
:
git
...
...
gargantext.cabal
View file @
bb78d480
...
@@ -117,6 +117,7 @@ library
...
@@ -117,6 +117,7 @@ library
Gargantext.Database.Query.Table.Node.UpdateOpaleye
Gargantext.Database.Query.Table.Node.UpdateOpaleye
Gargantext.Database.Query.Table.User
Gargantext.Database.Query.Table.User
Gargantext.Database.Schema.Ngrams
Gargantext.Database.Schema.Ngrams
Gargantext.System.Logging
Gargantext.Defaults
Gargantext.Defaults
Gargantext.Utils.Jobs
Gargantext.Utils.Jobs
Gargantext.Utils.Jobs.Internal
Gargantext.Utils.Jobs.Internal
...
...
src/Gargantext/API.hs
View file @
bb78d480
...
@@ -29,13 +29,14 @@ Pouillard (who mainly made it).
...
@@ -29,13 +29,14 @@ Pouillard (who mainly made it).
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeOperators #-}
module
Gargantext.API
module
Gargantext.API
where
where
import
Control.Concurrent
import
Control.Concurrent
import
Control.Exception
(
catch
,
finally
,
SomeException
{-, displayException, IOException-}
)
import
Control.Exception
(
catch
,
finally
,
SomeException
{-, displayException, IOException-}
)
import
Control.Lens
import
Control.Lens
hiding
(
Level
)
import
Control.Monad.Except
import
Control.Monad.Except
import
Control.Monad.Reader
(
runReaderT
)
import
Control.Monad.Reader
(
runReaderT
)
import
Data.Either
import
Data.Either
...
@@ -46,9 +47,8 @@ import Data.Text.Encoding (encodeUtf8)
...
@@ -46,9 +47,8 @@ import Data.Text.Encoding (encodeUtf8)
import
Data.Text.IO
(
putStrLn
)
import
Data.Text.IO
(
putStrLn
)
import
Data.Validity
import
Data.Validity
import
GHC.Base
(
Applicative
)
import
GHC.Base
(
Applicative
)
import
GHC.Generics
(
Generic
)
import
Gargantext.API.Admin.Auth.Types
(
AuthContext
)
import
Gargantext.API.Admin.Auth.Types
(
AuthContext
)
import
Gargantext.API.Admin.EnvTypes
(
Env
)
import
Gargantext.API.Admin.EnvTypes
(
Env
,
Mode
(
..
)
)
import
Gargantext.API.Admin.Settings
(
newEnv
)
import
Gargantext.API.Admin.Settings
(
newEnv
)
import
Gargantext.API.Admin.Types
(
FireWall
(
..
),
PortNumber
,
cookieSettings
,
jwtSettings
,
settings
)
import
Gargantext.API.Admin.Types
(
FireWall
(
..
),
PortNumber
,
cookieSettings
,
jwtSettings
,
settings
)
import
Gargantext.API.EKG
import
Gargantext.API.EKG
...
@@ -69,14 +69,12 @@ import Servant
...
@@ -69,14 +69,12 @@ import Servant
import
System.FilePath
import
System.FilePath
import
qualified
Gargantext.Database.Prelude
as
DB
import
qualified
Gargantext.Database.Prelude
as
DB
import
qualified
System.Cron.Schedule
as
Cron
import
qualified
System.Cron.Schedule
as
Cron
import
Gargantext.System.Logging
data
Mode
=
Dev
|
Mock
|
Prod
deriving
(
Show
,
Read
,
Generic
)
-- | startGargantext takes as parameters port number and Ini file.
-- | startGargantext takes as parameters port number and Ini file.
startGargantext
::
Mode
->
PortNumber
->
FilePath
->
IO
()
startGargantext
::
Mode
->
PortNumber
->
FilePath
->
IO
()
startGargantext
mode
port
file
=
do
startGargantext
mode
port
file
=
withLoggerHoisted
mode
$
\
logger
->
do
env
<-
newEnv
port
file
env
<-
newEnv
logger
port
file
runDbCheck
env
runDbCheck
env
portRouteInfo
port
portRouteInfo
port
app
<-
makeApp
env
app
<-
makeApp
env
...
...
src/Gargantext/API/Admin/EnvTypes.hs
View file @
bb78d480
...
@@ -2,15 +2,18 @@
...
@@ -2,15 +2,18 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
module
Gargantext.API.Admin.EnvTypes
(
module
Gargantext.API.Admin.EnvTypes
(
GargJob
(
..
)
GargJob
(
..
)
,
Env
(
..
)
,
Env
(
..
)
,
Mode
(
..
)
,
mkJobHandle
,
mkJobHandle
,
env_logger
,
env_logger
,
env_manager
,
env_manager
,
env_self_url
,
env_self_url
,
menv_firewall
,
menv_firewall
,
dev_env_logger
,
MockEnv
(
..
)
,
MockEnv
(
..
)
,
DevEnv
(
..
)
,
DevEnv
(
..
)
...
@@ -18,7 +21,7 @@ module Gargantext.API.Admin.EnvTypes (
...
@@ -18,7 +21,7 @@ module Gargantext.API.Admin.EnvTypes (
,
ConcreteJobHandle
-- opaque
,
ConcreteJobHandle
-- opaque
)
where
)
where
import
Control.Lens
hiding
((
:<
))
import
Control.Lens
hiding
(
Level
,
(
:<
))
import
Control.Monad.Except
import
Control.Monad.Except
import
Control.Monad.Reader
import
Control.Monad.Reader
import
Data.Pool
(
Pool
)
import
Data.Pool
(
Pool
)
...
@@ -29,24 +32,62 @@ import Network.HTTP.Client (Manager)
...
@@ -29,24 +32,62 @@ import Network.HTTP.Client (Manager)
import
Servant.Client
(
BaseUrl
)
import
Servant.Client
(
BaseUrl
)
import
Servant.Job.Async
(
HasJobEnv
(
..
),
Job
)
import
Servant.Job.Async
(
HasJobEnv
(
..
),
Job
)
import
qualified
Servant.Job.Async
as
SJ
import
qualified
Servant.Job.Async
as
SJ
import
System.Log.FastLogger
import
qualified
Servant.Job.Core
import
qualified
Servant.Job.Core
import
Gargantext.API.Admin.Types
import
Data.List
((
\\
))
import
qualified
Data.Text
as
T
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Job
import
Gargantext.API.Job
import
Gargantext.API.Prelude
(
GargM
)
import
Gargantext.API.Prelude
(
GargM
,
GargError
)
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Core.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Core.NLP
(
NLPServerMap
,
HasNLPServer
(
..
))
import
Gargantext.Core.NLP
(
NLPServerMap
,
HasNLPServer
(
..
))
import
Gargantext.Core.NodeStory
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
),
HasConfig
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
),
HasConfig
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
GargConfig
(
..
))
import
Gargantext.Prelude.Config
(
GargConfig
(
..
))
import
Gargantext.Prelude.Mail.Types
(
MailConfig
)
import
Gargantext.Prelude.Mail.Types
(
MailConfig
)
import
Gargantext.System.Logging
import
qualified
System.Log.FastLogger
as
FL
import
qualified
Gargantext.Utils.Jobs.Monad
as
Jobs
import
qualified
Gargantext.Utils.Jobs.Monad
as
Jobs
import
Gargantext.Utils.Jobs.Map
(
LoggerM
,
J
(
..
),
jTask
,
rjGetLog
)
import
Gargantext.Utils.Jobs.Map
(
LoggerM
,
J
(
..
),
jTask
,
rjGetLog
)
data
Mode
=
Dev
|
Mock
|
Prod
deriving
(
Show
,
Read
,
Generic
)
-- | Given the 'Mode' the server is running in, it returns the list of
-- allowed levels. For example for production we ignore everything which
-- has priority lower than "warning".
modeToLoggingLevels
::
Mode
->
[
LogLevel
]
modeToLoggingLevels
=
\
case
Dev
->
[
minBound
..
maxBound
]
Mock
->
[
minBound
..
maxBound
]
-- For production, accepts everything but DEBUG.
Prod
->
[
minBound
..
maxBound
]
\\
[
DEBUG
]
instance
MonadLogger
(
GargM
Env
GargError
)
where
getLogger
=
asks
_env_logger
instance
HasLogger
(
GargM
Env
GargError
)
where
data
instance
Logger
(
GargM
Env
GargError
)
=
GargLogger
{
logger_mode
::
Mode
,
logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
(
GargM
Env
GargError
)
=
Mode
type
instance
LogPayload
(
GargM
Env
GargError
)
=
FL
.
LogStr
initLogger
=
\
mode
->
do
logger_set
<-
liftIO
$
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
pure
$
GargLogger
mode
logger_set
destroyLogger
=
\
GargLogger
{
..
}
->
liftIO
$
FL
.
rmLoggerSet
logger_set
logMsg
=
\
(
GargLogger
mode
logger_set
)
lvl
msg
->
do
let
pfx
=
"["
<>
show
lvl
<>
"] "
when
(
lvl
`
elem
`
(
modeToLoggingLevels
mode
))
$
liftIO
$
FL
.
pushLogStrLn
logger_set
$
FL
.
toLogStr
pfx
<>
msg
logTxt
lgr
lvl
msg
=
logMsg
lgr
lvl
(
FL
.
toLogStr
$
T
.
unpack
msg
)
data
GargJob
data
GargJob
=
TableNgramsJob
=
TableNgramsJob
|
ForgotPasswordJob
|
ForgotPasswordJob
...
@@ -72,7 +113,7 @@ data GargJob
...
@@ -72,7 +113,7 @@ data GargJob
-- we need to remember to force the fields to WHNF at that point.
-- we need to remember to force the fields to WHNF at that point.
data
Env
=
Env
data
Env
=
Env
{
_env_settings
::
~
Settings
{
_env_settings
::
~
Settings
,
_env_logger
::
~
LoggerSet
,
_env_logger
::
~
(
Logger
(
GargM
Env
GargError
))
,
_env_pool
::
~
(
Pool
Connection
)
,
_env_pool
::
~
(
Pool
Connection
)
,
_env_nodeStory
::
~
NodeStoryEnv
,
_env_nodeStory
::
~
NodeStoryEnv
,
_env_manager
::
~
Manager
,
_env_manager
::
~
Manager
...
@@ -186,6 +227,8 @@ instance Jobs.MonadJobStatus (GargM Env err) where
...
@@ -186,6 +227,8 @@ instance Jobs.MonadJobStatus (GargM Env err) where
Just
msg
->
jobLogFailTotalWithMessage
msg
latest
Just
msg
->
jobLogFailTotalWithMessage
msg
latest
)
)
addMoreSteps
steps
jh
=
updateJobProgress
jh
(
jobLogAddMore
steps
)
data
MockEnv
=
MockEnv
data
MockEnv
=
MockEnv
{
_menv_firewall
::
!
FireWall
{
_menv_firewall
::
!
FireWall
}
}
...
@@ -193,9 +236,31 @@ data MockEnv = MockEnv
...
@@ -193,9 +236,31 @@ data MockEnv = MockEnv
makeLenses
''
M
ockEnv
makeLenses
''
M
ockEnv
instance
MonadLogger
(
GargM
DevEnv
GargError
)
where
getLogger
=
asks
_dev_env_logger
instance
HasLogger
(
GargM
DevEnv
GargError
)
where
data
instance
Logger
(
GargM
DevEnv
GargError
)
=
GargDevLogger
{
dev_logger_mode
::
Mode
,
dev_logger_set
::
FL
.
LoggerSet
}
type
instance
LogInitParams
(
GargM
DevEnv
GargError
)
=
Mode
type
instance
LogPayload
(
GargM
DevEnv
GargError
)
=
FL
.
LogStr
initLogger
=
\
mode
->
do
dev_logger_set
<-
liftIO
$
FL
.
newStderrLoggerSet
FL
.
defaultBufSize
pure
$
GargDevLogger
mode
dev_logger_set
destroyLogger
=
\
GargDevLogger
{
..
}
->
liftIO
$
FL
.
rmLoggerSet
dev_logger_set
logMsg
=
\
(
GargDevLogger
mode
logger_set
)
lvl
msg
->
do
let
pfx
=
"["
<>
show
lvl
<>
"] "
when
(
lvl
`
elem
`
(
modeToLoggingLevels
mode
))
$
liftIO
$
FL
.
pushLogStrLn
logger_set
$
FL
.
toLogStr
pfx
<>
msg
logTxt
lgr
lvl
msg
=
logMsg
lgr
lvl
(
FL
.
toLogStr
$
T
.
unpack
msg
)
data
DevEnv
=
DevEnv
data
DevEnv
=
DevEnv
{
_dev_env_settings
::
!
Settings
{
_dev_env_settings
::
!
Settings
,
_dev_env_config
::
!
GargConfig
,
_dev_env_config
::
!
GargConfig
,
_dev_env_logger
::
!
(
Logger
(
GargM
DevEnv
GargError
))
,
_dev_env_pool
::
!
(
Pool
Connection
)
,
_dev_env_pool
::
!
(
Pool
Connection
)
,
_dev_env_nodeStory
::
!
NodeStoryEnv
,
_dev_env_nodeStory
::
!
NodeStoryEnv
,
_dev_env_mail
::
!
MailConfig
,
_dev_env_mail
::
!
MailConfig
...
@@ -229,6 +294,8 @@ instance Jobs.MonadJobStatus (GargM DevEnv err) where
...
@@ -229,6 +294,8 @@ instance Jobs.MonadJobStatus (GargM DevEnv err) where
markFailed
_
_
=
pure
()
markFailed
_
_
=
pure
()
addMoreSteps
_
_
=
pure
()
instance
HasConfig
DevEnv
where
instance
HasConfig
DevEnv
where
hasConfig
=
dev_env_config
hasConfig
=
dev_env_config
...
...
src/Gargantext/API/Admin/Settings.hs
View file @
bb78d480
...
@@ -37,12 +37,12 @@ import System.Directory
...
@@ -37,12 +37,12 @@ import System.Directory
-- import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
-- import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
import
System.IO
(
FilePath
,
hClose
)
import
System.IO
(
FilePath
,
hClose
)
import
System.IO.Temp
(
withTempFile
)
import
System.IO.Temp
(
withTempFile
)
import
System.Log.FastLogger
import
qualified
Data.ByteString.Lazy
as
L
import
qualified
Data.ByteString.Lazy
as
L
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Prelude
-- import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
-- import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
import
Gargantext.Core.NLP
(
nlpServerMap
)
import
Gargantext.Core.NLP
(
nlpServerMap
)
import
Gargantext.Database.Prelude
(
databaseParameters
,
hasConfig
)
import
Gargantext.Database.Prelude
(
databaseParameters
,
hasConfig
)
...
@@ -54,6 +54,7 @@ import qualified Gargantext.Utils.Jobs as Jobs
...
@@ -54,6 +54,7 @@ import qualified Gargantext.Utils.Jobs as Jobs
import
qualified
Gargantext.Utils.Jobs.Monad
as
Jobs
import
qualified
Gargantext.Utils.Jobs.Monad
as
Jobs
import
qualified
Gargantext.Utils.Jobs.Queue
as
Jobs
import
qualified
Gargantext.Utils.Jobs.Queue
as
Jobs
import
qualified
Gargantext.Utils.Jobs.Settings
as
Jobs
import
qualified
Gargantext.Utils.Jobs.Settings
as
Jobs
import
Gargantext.System.Logging
devSettings
::
FilePath
->
IO
Settings
devSettings
::
FilePath
->
IO
Settings
devSettings
jwkFile
=
do
devSettings
jwkFile
=
do
...
@@ -176,8 +177,8 @@ readRepoEnv repoDir = do
...
@@ -176,8 +177,8 @@ readRepoEnv repoDir = do
devJwkFile
::
FilePath
devJwkFile
::
FilePath
devJwkFile
=
"dev.jwk"
devJwkFile
=
"dev.jwk"
newEnv
::
PortNumber
->
FilePath
->
IO
Env
newEnv
::
Logger
(
GargM
Env
GargError
)
->
PortNumber
->
FilePath
->
IO
Env
newEnv
port
file
=
do
newEnv
logger
port
file
=
do
!
manager_env
<-
newTlsManager
!
manager_env
<-
newTlsManager
!
settings'
<-
devSettings
devJwkFile
<&>
appPort
.~
port
-- TODO read from 'file'
!
settings'
<-
devSettings
devJwkFile
<&>
appPort
.~
port
-- TODO read from 'file'
when
(
port
/=
settings'
^.
appPort
)
$
when
(
port
/=
settings'
^.
appPort
)
$
...
@@ -200,7 +201,6 @@ newEnv port file = do
...
@@ -200,7 +201,6 @@ newEnv port file = do
&
Jobs
.
l_jsJobTimeout
.~
(
fromIntegral
$
config_env
^.
hasConfig
^.
gc_js_job_timeout
)
&
Jobs
.
l_jsJobTimeout
.~
(
fromIntegral
$
config_env
^.
hasConfig
^.
gc_js_job_timeout
)
&
Jobs
.
l_jsIDTimeout
.~
(
fromIntegral
$
config_env
^.
hasConfig
^.
gc_js_id_timeout
)
&
Jobs
.
l_jsIDTimeout
.~
(
fromIntegral
$
config_env
^.
hasConfig
^.
gc_js_id_timeout
)
!
jobs_env
<-
Jobs
.
newJobEnv
jobs_settings
prios'
manager_env
!
jobs_env
<-
Jobs
.
newJobEnv
jobs_settings
prios'
manager_env
!
logger
<-
newStderrLoggerSet
defaultBufSize
!
config_mail
<-
Mail
.
readConfig
file
!
config_mail
<-
Mail
.
readConfig
file
!
nlp_env
<-
nlpServerMap
<$>
NLP
.
readConfig
file
!
nlp_env
<-
nlpServerMap
<$>
NLP
.
readConfig
file
...
...
src/Gargantext/API/Dev.hs
View file @
bb78d480
...
@@ -29,16 +29,17 @@ import qualified Gargantext.Prelude.Mail as Mail
...
@@ -29,16 +29,17 @@ import qualified Gargantext.Prelude.Mail as Mail
import
qualified
Gargantext.Prelude.NLP
as
NLP
import
qualified
Gargantext.Prelude.NLP
as
NLP
import
Servant
import
Servant
import
System.IO
(
FilePath
)
import
System.IO
(
FilePath
)
import
Gargantext.System.Logging
type
IniPath
=
FilePath
type
IniPath
=
FilePath
-------------------------------------------------------------------
-------------------------------------------------------------------
withDevEnv
::
IniPath
->
(
DevEnv
->
IO
a
)
->
IO
a
withDevEnv
::
IniPath
->
(
DevEnv
->
IO
a
)
->
IO
a
withDevEnv
iniPath
k
=
do
withDevEnv
iniPath
k
=
withLoggerHoisted
Dev
$
\
logger
->
do
env
<-
newDevEnv
env
<-
newDevEnv
logger
k
env
-- `finally` cleanEnv env
k
env
-- `finally` cleanEnv env
where
where
newDevEnv
=
do
newDevEnv
logger
=
do
cfg
<-
readConfig
iniPath
cfg
<-
readConfig
iniPath
dbParam
<-
databaseParameters
iniPath
dbParam
<-
databaseParameters
iniPath
--nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
--nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
...
@@ -49,6 +50,7 @@ withDevEnv iniPath k = do
...
@@ -49,6 +50,7 @@ withDevEnv iniPath k = do
nlp_config
<-
NLP
.
readConfig
iniPath
nlp_config
<-
NLP
.
readConfig
iniPath
pure
$
DevEnv
pure
$
DevEnv
{
_dev_env_pool
=
pool
{
_dev_env_pool
=
pool
,
_dev_env_logger
=
logger
,
_dev_env_nodeStory
=
nodeStory_env
,
_dev_env_nodeStory
=
nodeStory_env
,
_dev_env_settings
=
setts
,
_dev_env_settings
=
setts
,
_dev_env_config
=
cfg
,
_dev_env_config
=
cfg
...
...
src/Gargantext/API/Job.hs
View file @
bb78d480
...
@@ -31,7 +31,7 @@ addErrorEvent message = addEvent "ERROR" message
...
@@ -31,7 +31,7 @@ addErrorEvent message = addEvent "ERROR" message
jobLogProgress
::
Int
->
JobLog
->
JobLog
jobLogProgress
::
Int
->
JobLog
->
JobLog
jobLogProgress
n
jl
=
over
(
scst_succeeded
.
_Just
)
(
+
n
)
$
jobLogProgress
n
jl
=
over
(
scst_succeeded
.
_Just
)
(
+
n
)
$
over
(
scst_remaining
.
_Just
)
(
\
x
->
x
-
n
)
jl
over
(
scst_remaining
.
_Just
)
(
\
x
->
max
0
(
x
-
n
)
)
jl
-- | Mark a job as completely done, by adding the 'remaining' into 'succeeded'.
-- | Mark a job as completely done, by adding the 'remaining' into 'succeeded'.
-- At the end 'scst_remaining' will be 0, and 'scst_succeeded' will be 'oldvalue + remaining'.
-- At the end 'scst_remaining' will be 0, and 'scst_succeeded' will be 'oldvalue + remaining'.
...
@@ -41,6 +41,9 @@ jobLogComplete jl =
...
@@ -41,6 +41,9 @@ jobLogComplete jl =
in
jl
&
over
scst_succeeded
(
Just
.
maybe
remainingNow
((
+
)
remainingNow
))
in
jl
&
over
scst_succeeded
(
Just
.
maybe
remainingNow
((
+
)
remainingNow
))
&
over
scst_remaining
(
const
(
Just
0
))
&
over
scst_remaining
(
const
(
Just
0
))
jobLogAddMore
::
Int
->
JobLog
->
JobLog
jobLogAddMore
moreSteps
jl
=
jl
&
over
(
scst_remaining
.
_Just
)
(
+
moreSteps
)
jobLogFailures
::
Int
->
JobLog
->
JobLog
jobLogFailures
::
Int
->
JobLog
->
JobLog
jobLogFailures
n
jl
=
over
(
scst_failed
.
_Just
)
(
+
n
)
$
jobLogFailures
n
jl
=
over
(
scst_failed
.
_Just
)
(
+
n
)
$
over
(
scst_remaining
.
_Just
)
(
\
x
->
x
-
n
)
jl
over
(
scst_remaining
.
_Just
)
(
\
x
->
x
-
n
)
jl
...
...
src/Gargantext/API/Node/Corpus/New.hs
View file @
bb78d480
...
@@ -21,7 +21,6 @@ module Gargantext.API.Node.Corpus.New
...
@@ -21,7 +21,6 @@ module Gargantext.API.Node.Corpus.New
import
Conduit
import
Conduit
import
Control.Lens
hiding
(
elements
,
Empty
)
import
Control.Lens
hiding
(
elements
,
Empty
)
import
Control.Monad
import
Data.Aeson
import
Data.Aeson
import
Data.Aeson.TH
(
deriveJSON
)
import
Data.Aeson.TH
(
deriveJSON
)
import
qualified
Data.ByteString.Base64
as
BSB64
import
qualified
Data.ByteString.Base64
as
BSB64
...
@@ -67,6 +66,7 @@ import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
...
@@ -67,6 +66,7 @@ import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
import
qualified
Gargantext.Core.Text.Corpus.API
as
API
import
qualified
Gargantext.Core.Text.Corpus.API
as
API
import
qualified
Gargantext.Core.Text.Corpus.Parsers
as
Parser
(
FileType
(
..
),
parseFormatC
)
import
qualified
Gargantext.Core.Text.Corpus.Parsers
as
Parser
(
FileType
(
..
),
parseFormatC
)
import
qualified
Gargantext.Database.GargDB
as
GargDB
import
qualified
Gargantext.Database.GargDB
as
GargDB
import
Gargantext.System.Logging
------------------------------------------------------------------------
------------------------------------------------------------------------
{-
{-
...
@@ -201,16 +201,17 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
...
@@ -201,16 +201,17 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
,
_wq_datafield
=
datafield
,
_wq_datafield
=
datafield
,
_wq_lang
=
l
,
_wq_lang
=
l
,
_wq_flowListWith
=
flw
})
maybeLimit
jobHandle
=
do
,
_wq_flowListWith
=
flw
})
maybeLimit
jobHandle
=
do
-- TODO ...
-- TODO ...
-- printDebug "[addToCorpusWithQuery] (cid, dbs)"
(cid, dbs)
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"(cid, dbs) "
<>
show
(
cid
,
dbs
)
-- printDebug "[addToCorpusWithQuery] datafield"
datafield
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"datafield "
<>
show
datafield
-- printDebug "[addToCorpusWithQuery] flowListWith"
flw
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"flowListWith "
<>
show
flw
addLanguageToCorpus
cid
l
addLanguageToCorpus
cid
l
case
datafield
of
case
datafield
of
Just
Web
->
do
Just
Web
->
do
-- printDebug "[addToCorpusWithQuery] processing web request"
datafield
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"processing web request "
<>
show
datafield
markStarted
1
jobHandle
markStarted
1
jobHandle
...
@@ -225,7 +226,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
...
@@ -225,7 +226,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
-- TODO if cid is folder -> create Corpus
-- TODO if cid is folder -> create Corpus
-- if cid is corpus -> add to corpus
-- if cid is corpus -> add to corpus
-- if cid is root -> create corpus in Private
-- if cid is root -> create corpus in Private
-- printDebug "[G.A.N.C.New] getDataText with query"
q
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"getDataText with query: "
<>
show
q
let
db
=
database2origin
dbs
let
db
=
database2origin
dbs
mPubmedAPIKey
<-
getUserPubmedAPIKey
user
mPubmedAPIKey
<-
getUserPubmedAPIKey
user
-- printDebug "[addToCorpusWithQuery] mPubmedAPIKey" mPubmedAPIKey
-- printDebug "[addToCorpusWithQuery] mPubmedAPIKey" mPubmedAPIKey
...
@@ -235,11 +236,11 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
...
@@ -235,11 +236,11 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
case
eTxt
of
case
eTxt
of
Right
txt
->
do
Right
txt
->
do
-- TODO Sum lenghts of each txt elements
-- TODO Sum lenghts of each txt elements
$
(
logLocM
)
DEBUG
"Processing dataText results"
markProgress
1
jobHandle
markProgress
1
jobHandle
void
$
flowDataText
user
txt
(
Multi
l
)
cid
(
Just
flw
)
jobHandle
corpusId
<-
flowDataText
user
txt
(
Multi
l
)
cid
(
Just
flw
)
jobHandle
-- printDebug "corpus id" cids
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"corpus id "
<>
show
corpusId
-- printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
-- printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
sendMail
user
sendMail
user
-- TODO ...
-- TODO ...
...
@@ -247,6 +248,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
...
@@ -247,6 +248,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
Left
err
->
do
Left
err
->
do
-- printDebug "Error: " err
-- printDebug "Error: " err
$
(
logLocM
)
ERROR
(
T
.
pack
$
show
err
)
markFailed
(
Just
$
T
.
pack
(
show
err
))
jobHandle
markFailed
(
Just
$
T
.
pack
(
show
err
))
jobHandle
type
AddWithForm
=
Summary
"Add with FormUrlEncoded to corpus endpoint"
type
AddWithForm
=
Summary
"Add with FormUrlEncoded to corpus endpoint"
...
...
src/Gargantext/API/Prelude.hs
View file @
bb78d480
...
@@ -49,6 +49,7 @@ import Servant
...
@@ -49,6 +49,7 @@ import Servant
import
Servant.Job.Async
import
Servant.Job.Async
import
Servant.Job.Core
(
HasServerError
(
..
),
serverError
)
import
Servant.Job.Core
(
HasServerError
(
..
),
serverError
)
import
qualified
Servant.Job.Types
as
SJ
import
qualified
Servant.Job.Types
as
SJ
import
Gargantext.System.Logging
class
HasJoseError
e
where
class
HasJoseError
e
where
_JoseError
::
Prism'
e
Jose
.
Error
_JoseError
::
Prism'
e
Jose
.
Error
...
@@ -88,7 +89,7 @@ type GargServerC env err m =
...
@@ -88,7 +89,7 @@ type GargServerC env err m =
type
GargServerT
env
err
m
api
=
GargServerC
env
err
m
=>
ServerT
api
m
type
GargServerT
env
err
m
api
=
GargServerC
env
err
m
=>
ServerT
api
m
type
GargServer
api
=
forall
env
err
m
.
GargServerT
env
err
m
api
type
GargServer
api
=
forall
env
err
m
.
MonadLogger
m
=>
GargServerT
env
err
m
api
-- This is the concrete monad. It needs to be used as little as possible.
-- This is the concrete monad. It needs to be used as little as possible.
type
GargM
env
err
=
ReaderT
env
(
ExceptT
err
IO
)
type
GargM
env
err
=
ReaderT
env
(
ExceptT
err
IO
)
...
...
src/Gargantext/Database/Action/Flow.hs
View file @
bb78d480
...
@@ -55,9 +55,11 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
...
@@ -55,9 +55,11 @@ module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
import
Conduit
import
Conduit
import
Control.Lens
hiding
(
elements
,
Indexed
)
import
Control.Lens
hiding
(
elements
,
Indexed
)
import
Control.Monad
(
void
)
import
Data.Aeson.TH
(
deriveJSON
)
import
Data.Aeson.TH
(
deriveJSON
)
import
Data.Conduit.Internal
(
zipSources
)
import
Data.Conduit.Internal
(
zipSources
)
import
Data.Either
import
Data.Either
import
Data.Foldable
(
for_
)
import
Data.HashMap.Strict
(
HashMap
)
import
Data.HashMap.Strict
(
HashMap
)
import
Data.Hashable
(
Hashable
)
import
Data.Hashable
(
Hashable
)
import
Data.List
(
concat
)
import
Data.List
(
concat
)
...
@@ -69,6 +71,7 @@ import Data.Set (Set)
...
@@ -69,6 +71,7 @@ import Data.Set (Set)
import
Data.Swagger
import
Data.Swagger
import
Data.Tuple.Extra
(
first
,
second
)
import
Data.Tuple.Extra
(
first
,
second
)
import
GHC.Generics
(
Generic
)
import
GHC.Generics
(
Generic
)
import
GHC.Num
(
fromInteger
)
import
Gargantext.API.Ngrams.Tools
(
getTermsWith
)
import
Gargantext.API.Ngrams.Tools
(
getTermsWith
)
import
Gargantext.Core
(
Lang
(
..
),
PosTagAlgo
(
..
))
import
Gargantext.Core
(
Lang
(
..
),
PosTagAlgo
(
..
))
import
Gargantext.Core
(
withDefaultLanguage
)
import
Gargantext.Core
(
withDefaultLanguage
)
...
@@ -97,7 +100,7 @@ import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContex
...
@@ -97,7 +100,7 @@ import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContex
import
Gargantext.Database.Action.Search
(
searchDocInDatabase
)
import
Gargantext.Database.Action.Search
(
searchDocInDatabase
)
import
Gargantext.Database.Admin.Config
(
userMaster
,
corpusMasterName
)
import
Gargantext.Database.Admin.Config
(
userMaster
,
corpusMasterName
)
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Hyperdata
import
Gargantext.Database.Admin.Types.Node
-- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
import
Gargantext.Database.Admin.Types.Node
hiding
(
DEBUG
)
-- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.ContextNodeNgrams2
import
Gargantext.Database.Query.Table.ContextNodeNgrams2
import
Gargantext.Database.Query.Table.Ngrams
import
Gargantext.Database.Query.Table.Ngrams
...
@@ -113,12 +116,14 @@ import Gargantext.Database.Schema.Node (node_hyperdata)
...
@@ -113,12 +116,14 @@ import Gargantext.Database.Schema.Node (node_hyperdata)
import
Gargantext.Database.Types
import
Gargantext.Database.Types
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Crypto.Hash
(
Hash
)
import
Gargantext.Prelude.Crypto.Hash
(
Hash
)
import
Gargantext.System.Logging
import
Gargantext.Utils.Jobs
(
JobHandle
,
MonadJobStatus
(
..
))
import
Gargantext.Utils.Jobs
(
JobHandle
,
MonadJobStatus
(
..
))
import
System.FilePath
(
FilePath
)
import
System.FilePath
(
FilePath
)
import
qualified
Data.Conduit
as
C
import
qualified
Data.Conduit
as
C
import
qualified
Data.Conduit.List
as
CL
import
qualified
Data.Conduit.List
as
CL
import
qualified
Data.Conduit.List
as
CList
import
qualified
Data.Conduit.List
as
CList
import
qualified
Data.HashMap.Strict
as
HashMap
import
qualified
Data.HashMap.Strict
as
HashMap
import
qualified
Data.List
as
List
import
qualified
Data.Map.Strict
as
Map
import
qualified
Data.Map.Strict
as
Map
import
qualified
Data.Set
as
Set
import
qualified
Data.Set
as
Set
import
qualified
Data.Text
as
T
import
qualified
Data.Text
as
T
...
@@ -132,7 +137,7 @@ import qualified PUBMED.Types as PUBMED
...
@@ -132,7 +137,7 @@ import qualified PUBMED.Types as PUBMED
-- Imports for upgrade function
-- Imports for upgrade function
import
Gargantext.Database.Query.Tree.Root
(
getRootId
)
import
Gargantext.Database.Query.Tree.Root
(
getRootId
)
import
Gargantext.Database.Query.Tree
(
findNodesId
)
import
Gargantext.Database.Query.Tree
(
findNodesId
)
import
qualified
Data.List
as
List
------------------------------------------------------------------------
------------------------------------------------------------------------
-- TODO use internal with API name (could be old data)
-- TODO use internal with API name (could be old data)
data
DataOrigin
=
InternalOrigin
{
_do_api
::
API
.
ExternalAPIs
}
data
DataOrigin
=
InternalOrigin
{
_do_api
::
API
.
ExternalAPIs
}
...
@@ -205,12 +210,15 @@ flowDataText :: forall env err m.
...
@@ -205,12 +210,15 @@ flowDataText :: forall env err m.
->
JobHandle
m
->
JobHandle
m
->
m
CorpusId
->
m
CorpusId
flowDataText
u
(
DataOld
ids
)
tt
cid
mfslw
_
=
do
flowDataText
u
(
DataOld
ids
)
tt
cid
mfslw
_
=
do
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"Found "
<>
show
(
length
ids
)
<>
" old node IDs"
(
_userId
,
userCorpusId
,
listId
)
<-
createNodes
u
(
Right
[
cid
])
corpusType
(
_userId
,
userCorpusId
,
listId
)
<-
createNodes
u
(
Right
[
cid
])
corpusType
_
<-
Doc
.
add
userCorpusId
ids
_
<-
Doc
.
add
userCorpusId
ids
flowCorpusUser
(
_tt_lang
tt
)
u
userCorpusId
listId
corpusType
mfslw
flowCorpusUser
(
_tt_lang
tt
)
u
userCorpusId
listId
corpusType
mfslw
where
where
corpusType
=
(
Nothing
::
Maybe
HyperdataCorpus
)
corpusType
=
(
Nothing
::
Maybe
HyperdataCorpus
)
flowDataText
u
(
DataNew
(
mLen
,
txtC
))
tt
cid
mfslw
jobHandle
=
flowDataText
u
(
DataNew
(
mLen
,
txtC
))
tt
cid
mfslw
jobHandle
=
do
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"Found "
<>
show
mLen
<>
" new documents to process"
for_
(
mLen
<&>
fromInteger
)
(`
addMoreSteps
`
jobHandle
)
flowCorpus
u
(
Right
[
cid
])
tt
mfslw
(
mLen
,
(
transPipe
liftBase
txtC
))
jobHandle
flowCorpus
u
(
Right
[
cid
])
tt
mfslw
(
mLen
,
(
transPipe
liftBase
txtC
))
jobHandle
------------------------------------------------------------------------
------------------------------------------------------------------------
...
@@ -279,59 +287,23 @@ flow :: forall env err m a c.
...
@@ -279,59 +287,23 @@ flow :: forall env err m a c.
flow
c
u
cn
la
mfslw
(
mLength
,
docsC
)
jobHandle
=
do
flow
c
u
cn
la
mfslw
(
mLength
,
docsC
)
jobHandle
=
do
(
_userId
,
userCorpusId
,
listId
)
<-
createNodes
u
cn
c
(
_userId
,
userCorpusId
,
listId
)
<-
createNodes
u
cn
c
-- TODO if public insertMasterDocs else insertUserDocs
-- TODO if public insertMasterDocs else insertUserDocs
_
<-
runConduit
$
zipSources
(
yieldMany
[
1
..
])
docsC
runConduit
$
zipSources
(
yieldMany
[
1
..
])
docsC
.|
CList
.
chunksOf
100
.|
CList
.
chunksOf
100
.|
mapMC
insertDocs'
.|
mapM_C
(
\
docs
->
void
$
insertDocs'
docs
>>=
Doc
.
add
userCorpusId
)
.|
mapM_C
(
\
ids'
->
do
.|
sinkNull
_
<-
Doc
.
add
userCorpusId
ids'
pure
()
)
$
(
logLocM
)
DEBUG
"Calling flowCorpusUser"
.|
sinkList
flowCorpusUser
(
la
^.
tt_lang
)
u
userCorpusId
listId
c
mfslw
_
<-
flowCorpusUser
(
la
^.
tt_lang
)
u
userCorpusId
listId
c
mfslw
-- ids <- traverse (\(idx, doc) -> do
-- id <- insertMasterDocs c la doc
-- logStatus JobLog { _scst_succeeded = Just $ 1 + idx
-- , _scst_failed = Just 0
-- , _scst_remaining = Just $ length docs - idx
-- , _scst_events = Just []
-- }
-- pure id
-- ) (zip [1..] docs)
--printDebug "[flow] calling flowCorpusUser" (0 :: Int)
pure
userCorpusId
--flowCorpusUser (la ^. tt_lang) u cn c ids mfslw
where
where
insertDocs'
::
[(
Integer
,
a
)]
->
m
[
NodeId
]
insertDocs'
::
[(
Integer
,
a
)]
->
m
[
NodeId
]
insertDocs'
[]
=
pure
[]
insertDocs'
[]
=
pure
[]
insertDocs'
docs
=
do
insertDocs'
docs
=
do
-- printDebug "[flow] calling insertDoc, ([idx], mLength) = "
(fst <$> docs, mLength)
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"calling insertDoc, ([idx], mLength) = "
<>
show
(
fst
<$>
docs
,
mLength
)
ids
<-
insertMasterDocs
c
la
(
snd
<$>
docs
)
ids
<-
insertMasterDocs
c
la
(
snd
<$>
docs
)
let
maxIdx
=
maximum
(
fst
<$>
docs
)
markProgress
(
length
docs
)
jobHandle
case
mLength
of
Nothing
->
pure
()
Just
_len
->
do
let
succeeded
=
fromIntegral
(
1
+
maxIdx
)
-- let remaining = fromIntegral (len - maxIdx)
-- Reconstruct the correct update state by using 'markStarted' and the other primitives.
-- We do this slightly awkward arithmetic such that when we call 'markProgress' we reduce
-- the number of 'remaining' of exactly '1 + maxIdx', and we will end up with a 'JobLog'
-- looking like this:
-- JobLog
-- { _scst_succeeded = Just $ fromIntegral $ 1 + maxIdx
-- , _scst_failed = Just 0
-- , _scst_remaining = Just $ fromIntegral $ len - maxIdx
-- , _scst_events = Just []
-- }
-- markStarted (remaining + succeeded) jobHandle
markProgress
succeeded
jobHandle
pure
ids
pure
ids
------------------------------------------------------------------------
------------------------------------------------------------------------
createNodes
::
(
FlowCmdM
env
err
m
createNodes
::
(
FlowCmdM
env
err
m
,
MkCorpus
c
,
MkCorpus
c
...
...
src/Gargantext/Database/Action/Flow/Types.hs
View file @
bb78d480
...
@@ -30,6 +30,7 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
...
@@ -30,6 +30,7 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import
Gargantext.Database.Prelude
(
CmdM
)
import
Gargantext.Database.Prelude
(
CmdM
)
import
Gargantext.Database.Query.Table.Node.Document.Insert
import
Gargantext.Database.Query.Table.Node.Document.Insert
import
Gargantext.Database.Query.Tree.Error
(
HasTreeError
)
import
Gargantext.Database.Query.Tree.Error
(
HasTreeError
)
import
Gargantext.System.Logging
type
FlowCmdM
env
err
m
=
type
FlowCmdM
env
err
m
=
(
CmdM
env
err
m
(
CmdM
env
err
m
...
@@ -37,6 +38,7 @@ type FlowCmdM env err m =
...
@@ -37,6 +38,7 @@ type FlowCmdM env err m =
,
HasNodeError
err
,
HasNodeError
err
,
HasInvalidError
err
,
HasInvalidError
err
,
HasTreeError
err
,
HasTreeError
err
,
MonadLogger
m
)
)
type
FlowCorpus
a
=
(
AddUniqId
a
type
FlowCorpus
a
=
(
AddUniqId
a
...
...
src/Gargantext/Database/Query/Table/Node/Document/Add.hs
View file @
bb78d480
...
@@ -39,6 +39,13 @@ add pId ns = runPGSQuery queryAdd (Only $ Values fields inputData)
...
@@ -39,6 +39,13 @@ add pId ns = runPGSQuery queryAdd (Only $ Values fields inputData)
fields
=
map
(
\
t
->
QualifiedIdentifier
Nothing
t
)
inputSqlTypes
fields
=
map
(
\
t
->
QualifiedIdentifier
Nothing
t
)
inputSqlTypes
inputData
=
prepare
pId
ns
inputData
=
prepare
pId
ns
-- | Adds a single document. Useful for debugging purposes, but
-- not as efficient as adding documents in bulk via 'add'.
add_one
::
CorpusId
->
ContextId
->
Cmd
err
[
Only
Int
]
add_one
pId
ctxId
=
runPGSQuery
queryAdd
(
Only
$
Values
fields
[
InputData
pId
ctxId
])
where
fields
=
map
(
\
t
->
QualifiedIdentifier
Nothing
t
)
inputSqlTypes
add_debug
::
CorpusId
->
[
ContextId
]
->
Cmd
err
ByteString
add_debug
::
CorpusId
->
[
ContextId
]
->
Cmd
err
ByteString
add_debug
pId
ns
=
formatPGSQuery
queryAdd
(
Only
$
Values
fields
inputData
)
add_debug
pId
ns
=
formatPGSQuery
queryAdd
(
Only
$
Values
fields
inputData
)
where
where
...
...
src/Gargantext/System/Logging.hs
0 → 100644
View file @
bb78d480
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module
Gargantext.System.Logging
(
LogLevel
(
..
)
,
HasLogger
(
..
)
,
MonadLogger
(
..
)
,
logM
,
logLocM
,
withLogger
,
withLoggerHoisted
)
where
import
Language.Haskell.TH
hiding
(
Type
)
import
Control.Exception.Lifted
(
bracket
)
import
Control.Monad.IO.Class
import
Control.Monad.Trans.Control
import
Data.Kind
(
Type
)
import
Prelude
import
qualified
Data.Text
as
T
import
qualified
Language.Haskell.TH.Syntax
as
TH
data
LogLevel
=
-- | Debug messages
DEBUG
-- | Information
|
INFO
-- | Normal runtime conditions
|
NOTICE
-- | General Warnings
|
WARNING
-- | General Errors
|
ERROR
-- | Severe situations
|
CRITICAL
-- | Take immediate action
|
ALERT
-- | System is unusable
|
EMERGENCY
deriving
(
Show
,
Eq
,
Ord
,
Enum
,
Bounded
)
-- | This is a barebore logging interface which we
-- can extend to plug a proper logging library, without
-- the details of the logger cropping up everywhere in
-- the rest of the codebase.
class
HasLogger
m
where
data
family
Logger
m
::
Type
type
family
LogInitParams
m
::
Type
type
family
LogPayload
m
::
Type
initLogger
::
LogInitParams
m
->
(
forall
m1
.
MonadIO
m1
=>
m1
(
Logger
m
))
destroyLogger
::
Logger
m
->
(
forall
m1
.
MonadIO
m1
=>
m1
()
)
logMsg
::
Logger
m
->
LogLevel
->
LogPayload
m
->
m
()
logTxt
::
Logger
m
->
LogLevel
->
T
.
Text
->
m
()
-- | Separate typeclass to get hold of a 'Logger' from within a monad.
-- We keey 'HasLogger' and 'MonadLogger' separate to enforce compositionality,
-- i.e. we can still give instances to 'HasLogger' for things like 'IO' without
-- having to force actually acquiring a logger for those monads.
class
HasLogger
m
=>
MonadLogger
m
where
getLogger
::
m
(
Logger
m
)
-- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
logM
::
(
Monad
m
,
MonadLogger
m
)
=>
LogLevel
->
T
.
Text
->
m
()
logM
level
msg
=
do
logger
<-
getLogger
logTxt
logger
level
msg
-- | Like 'logM', but it automatically adds the file and line number to
-- the output log.
logLocM
::
ExpQ
logLocM
=
[
|
\
level
msg
->
let
loc
=
$
(
getLocTH
)
in
logM
level
(
formatWithLoc
loc
msg
)
|
]
formatWithLoc
::
Loc
->
T
.
Text
->
T
.
Text
formatWithLoc
loc
msg
=
"["
<>
locationToText
<>
"] "
<>
msg
where
locationToText
::
T
.
Text
locationToText
=
T
.
pack
$
(
loc_filename
loc
)
++
':'
:
(
line
loc
)
++
':'
:
(
char
loc
)
where
line
=
show
.
fst
.
loc_start
char
=
show
.
snd
.
loc_start
getLocTH
::
ExpQ
getLocTH
=
[
|
$
(
location
>>=
liftLoc
)
|
]
liftLoc
::
Loc
->
Q
Exp
liftLoc
(
Loc
a
b
c
(
d1
,
d2
)
(
e1
,
e2
))
=
[
|
Loc
$
(
TH
.
lift
a
)
$
(
TH
.
lift
b
)
$
(
TH
.
lift
c
)
(
$
(
TH
.
lift
d1
),
$
(
TH
.
lift
d2
))
(
$
(
TH
.
lift
e1
),
$
(
TH
.
lift
e2
))
|
]
-- | exception-safe combinator that creates and destroys a logger.
-- Think about it like a 'bracket' function from 'Control.Exception'.
withLogger
::
(
MonadBaseControl
IO
m
,
MonadIO
m
,
HasLogger
m
)
=>
LogInitParams
m
->
(
Logger
m
->
m
a
)
->
m
a
withLogger
params
=
bracket
(
initLogger
params
)
destroyLogger
-- | Like 'withLogger', but it allows creating a 'Logger' that can run in
-- a different monad from within an 'IO' action.
withLoggerHoisted
::
(
MonadBaseControl
IO
m
,
HasLogger
m
)
=>
LogInitParams
m
->
(
Logger
m
->
IO
a
)
->
IO
a
withLoggerHoisted
params
act
=
bracket
(
initLogger
params
)
destroyLogger
act
src/Gargantext/Utils/Jobs/Monad.hs
View file @
bb78d480
...
@@ -212,3 +212,6 @@ class MonadJobStatus m where
...
@@ -212,3 +212,6 @@ class MonadJobStatus m where
-- | Finish tracking a job by marking all the remaining steps as failed. Attach an optional
-- | Finish tracking a job by marking all the remaining steps as failed. Attach an optional
-- message to the failure.
-- message to the failure.
markFailed
::
Maybe
T
.
Text
->
JobHandle
m
->
m
()
markFailed
::
Maybe
T
.
Text
->
JobHandle
m
->
m
()
-- | Add 'n' more steps to the running computation, they will be marked as remaining.
addMoreSteps
::
MonadJobStatus
m
=>
Int
->
JobHandle
m
->
m
()
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