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
142
Issues
142
List
Board
Labels
Milestones
Merge Requests
8
Merge Requests
8
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
6d6384ff
Verified
Commit
6d6384ff
authored
Aug 30, 2024
by
Przemyslaw Kaminski
1
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[toml] notifications
parent
9e4f7476
Pipeline
#6564
canceled with stages
in 11 minutes and 3 seconds
Changes
17
Pipelines
1
Show whitespace changes
Inline
Side-by-side
Showing
17 changed files
with
120 additions
and
226 deletions
+120
-226
Main.hs
bin/gargantext-central-exchange/Main.hs
+0
-81
gargantext-settings.toml_toModify
gargantext-settings.toml_toModify
+5
-0
gargantext.cabal
gargantext.cabal
+0
-22
API.hs
src/Gargantext/API.hs
+8
-8
EnvTypes.hs
src/Gargantext/API/Admin/EnvTypes.hs
+6
-2
Settings.hs
src/Gargantext/API/Admin/Settings.hs
+2
-2
CentralExchange.hs
src/Gargantext/Core/AsyncUpdates/CentralExchange.hs
+21
-15
Constants.hs
src/Gargantext/Core/AsyncUpdates/Constants.hs
+0
-41
Dispatcher.hs
src/Gargantext/Core/AsyncUpdates/Dispatcher.hs
+8
-7
Types.hs
src/Gargantext/Core/AsyncUpdates/Dispatcher/Types.hs
+0
-1
Config.hs
src/Gargantext/Core/Config.hs
+5
-1
Types.hs
src/Gargantext/Core/Config/Types.hs
+23
-0
gargantext-settings.toml
test-data/gargantext-settings.toml
+0
-24
test_config.toml
test-data/test_config.toml
+5
-0
API.hs
test/Test/API.hs
+4
-3
Notifications.hs
test/Test/API/Notifications.hs
+18
-11
Main.hs
test/drivers/hspec/Main.hs
+15
-8
No files found.
bin/gargantext-central-exchange/Main.hs
deleted
100644 → 0
View file @
9e4f7476
{-|
Module : Main.hs
Description : Gargantext central exchange for async notifications
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE Strict #-}
module
Main
where
import
Control.Concurrent
(
threadDelay
)
import
Control.Monad
(
join
,
mapM_
)
import
Data.ByteString.Char8
qualified
as
C
import
Data.Text
qualified
as
T
import
Gargantext.Core.AsyncUpdates.CentralExchange
(
gServer
)
import
Gargantext.Core.AsyncUpdates.Constants
(
ceBind
,
ceConnect
)
import
Gargantext.Prelude
import
Nanomsg
import
Options.Applicative
data
Command
=
CEServer
|
SimpleServer
|
WSServer
|
Client
parser
::
Parser
(
IO
()
)
parser
=
subparser
(
command
"ce-server"
(
info
(
pure
gServer
)
idm
)
<>
command
"simple-server"
(
info
(
pure
simpleServer
)
idm
)
<>
command
"ws-server"
(
info
(
pure
wsServer
)
idm
)
<>
command
"client"
(
info
(
pure
gClient
)
idm
)
)
main
::
IO
()
main
=
join
$
execParser
(
info
parser
idm
)
simpleServer
::
IO
()
simpleServer
=
do
withSocket
Pull
$
\
s
->
do
_
<-
bind
s
ceBind
putText
"[simpleServer] receiving"
forever
$
do
mr
<-
recvMalloc
s
1024
C
.
putStrLn
mr
-- case mr of
-- Nothing -> pure ()
-- Just r -> C.putStrLn r
-- threadDelay 10000
wsServer
::
IO
()
wsServer
=
do
withSocket
Pull
$
\
ws
->
do
_
<-
bind
ws
"ws://*:5560"
forever
$
do
putText
"[wsServer] receiving"
r
<-
recv
ws
C
.
putStrLn
r
gClient
::
IO
()
gClient
=
do
withSocket
Push
$
\
s
->
do
_
<-
connect
s
ceConnect
-- let str = C.unwords (take 10 $ repeat "hello")
let
str
=
"{
\"
type
\"
:
\"
update_tree_first_level
\"
,
\"
node_id
\"
: -1}"
C
.
putStrLn
$
C
.
pack
"sending: "
<>
str
send
s
str
withSocket
Push
$
\
s
->
do
_
<-
connect
s
ceConnect
let
str2
=
"{
\"
type
\"
:
\"
update_tree_first_level
\"
,
\"
node_id
\"
: -2}"
C
.
putStrLn
$
C
.
pack
"sending: "
<>
str2
send
s
str2
gargantext-settings.toml_toModify
View file @
6d6384ff
...
...
@@ -120,6 +120,11 @@ smtp_host = "localhost"
# HOST_password = password
[notifications]
central-exchange = { bind = "tcp://*:5560", connect = "tcp://localhost:5560" }
dispatcher = { bind = "tcp://*:5561", connect = "tcp://localhost:5561" }
[nlp]
# Possible choices (see Gargantext.Core.NLP):
# - spacy:// (for http:// Spacy)
...
...
gargantext.cabal
View file @
6d6384ff
...
...
@@ -168,7 +168,6 @@ library
Gargantext.Core.AsyncUpdates
Gargantext.Core.AsyncUpdates.CentralExchange
Gargantext.Core.AsyncUpdates.CentralExchange.Types
Gargantext.Core.AsyncUpdates.Constants
Gargantext.Core.AsyncUpdates.Dispatcher
Gargantext.Core.AsyncUpdates.Dispatcher.Subscriptions
Gargantext.Core.AsyncUpdates.Dispatcher.Types
...
...
@@ -799,27 +798,6 @@ executable gargantext-server
, unordered-containers ^>= 0.2.16.0
, vector ^>= 0.7.3
executable gargantext-central-exchange
import:
defaults
main-is: Main.hs
other-modules:
Paths_gargantext
hs-source-dirs:
bin/gargantext-central-exchange
build-depends:
bytestring ^>= 0.10.12.0
, gargantext
, gargantext-prelude
, nanomsg-haskell >= 0.2.4 && < 0.3
-- , nng-haskell
, optparse-applicative >= 0.18.1.0 && < 0.19
, optparse-generic ^>= 1.4.7
, postgresql-simple ^>= 0.6.4
, text ^>= 1.2.4.1
, unordered-containers ^>= 0.2.16.0
, vector ^>= 0.7.3
common testDependencies
build-depends:
base >=4.7 && <5
...
...
src/Gargantext/API.hs
View file @
6d6384ff
...
...
@@ -44,15 +44,15 @@ import Data.Text.Encoding qualified as TE
import
Data.Text.IO
(
putStrLn
)
import
Data.Validity
import
Gargantext.API.Admin.Auth.Types
(
AuthContext
)
import
Gargantext.API.Admin.EnvTypes
(
Env
,
Mode
(
..
))
import
Gargantext.API.Admin.EnvTypes
(
Env
,
Mode
(
..
)
,
_env_config
)
import
Gargantext.API.Admin.Settings
(
newEnv
)
import
Gargantext.API.Admin.Types
(
FireWall
(
..
),
PortNumber
,
cookieSettings
,
jwtSettings
,
settings
,
corsSettings
,
microservicesSettings
)
import
Gargantext.API.Middleware
(
logStdoutDevSanitised
)
import
Gargantext.API.Routes.Named
(
API
)
import
Gargantext.API.Routes.Named.EKG
import
Gargantext.API.Server.Named
(
server
)
import
Gargantext.Core.
AsyncUpdates.Constants
qualified
as
AUConstants
import
Gargantext.Core.Config.Types
(
CORSOrigin
(
..
),
CORSSettings
,
SettingsFile
(
..
),
corsAllowedOrigins
,
msProxyPort
)
import
Gargantext.Core.
Config
(
_gc_notifications_config
)
import
Gargantext.Core.Config.Types
(
CORSOrigin
(
..
),
CORSSettings
,
NotificationsConfig
(
..
),
SettingsFile
(
..
),
corsAllowedOrigins
,
msProxyPort
)
import
Gargantext.Database.Prelude
qualified
as
DB
import
Gargantext.MicroServices.ReverseProxy
(
microServicesProxyApp
)
import
Gargantext.Prelude
hiding
(
putStrLn
)
...
...
@@ -75,7 +75,7 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mod
env
<-
newEnv
logger
port
sf
let
proxyPort
=
env
^.
settings
.
microservicesSettings
.
msProxyPort
runDbCheck
env
portRouteInfo
port
proxyPort
portRouteInfo
(
_gc_notifications_config
$
_env_config
env
)
port
proxyPort
app
<-
makeApp
env
mid
<-
makeGargMiddleware
(
env
^.
settings
.
corsSettings
)
mode
periodicActions
<-
schedulePeriodicActions
env
...
...
@@ -96,8 +96,8 @@ startGargantext mode port sf@(SettingsFile settingsFile) = withLoggerHoisted mod
"' before running gargantext-server (only the first time)."
oneHour
=
Clock
.
fromNanoSecs
3600
_000_000_000
portRouteInfo
::
PortNumber
->
PortNumber
->
IO
()
portRouteInfo
mainPort
proxyPort
=
do
portRouteInfo
::
NotificationsConfig
->
PortNumber
->
PortNumber
->
IO
()
portRouteInfo
nc
mainPort
proxyPort
=
do
putStrLn
"=========================================================================================================="
putStrLn
" GarganText Main Routes"
putStrLn
"=========================================================================================================="
...
...
@@ -105,8 +105,8 @@ portRouteInfo mainPort proxyPort = do
putStrLn
$
" - Swagger UI (API documentation)...........: "
<>
"http://localhost:"
<>
toUrlPiece
mainPort
<>
"/swagger-ui"
putStrLn
$
" - Playground GraphQL (API documentation)...: "
<>
"http://localhost:"
<>
toUrlPiece
mainPort
<>
"/gql"
putStrLn
$
" - Microservices proxy .....................: "
<>
"http://localhost:"
<>
toUrlPiece
proxyPort
putStrLn
$
" - Central exchange.........................: "
<>
"nanomsg: "
<>
pack
AUConstants
.
ceBind
putStrLn
$
" - Dispatcher internal......................: "
<>
"nanomsg: "
<>
pack
AUConstants
.
dispatcherBind
putStrLn
$
" - Central exchange.........................: "
<>
"nanomsg: "
<>
_nc_central_exchange_bind
nc
putStrLn
$
" - Dispatcher internal......................: "
<>
"nanomsg: "
<>
_nc_dispatcher_bind
nc
putStrLn
$
" - WebSocket address........................: "
<>
"ws://localhost:"
<>
toUrlPiece
mainPort
<>
"/ws"
putStrLn
"=========================================================================================================="
...
...
src/Gargantext/API/Admin/EnvTypes.hs
View file @
6d6384ff
...
...
@@ -174,7 +174,9 @@ instance Jobs.MonadJob (GargM Env err) GargJob (Seq JobLog) JobLog where
getJobEnv
=
asks
(
view
env_jobs
)
instance
CET
.
HasCentralExchangeNotification
Env
where
ce_notify
m
=
liftBase
$
CE
.
notify
m
ce_notify
m
=
do
nc
<-
asks
(
view
env_config
)
liftBase
$
CE
.
notify
(
_gc_notifications_config
nc
)
m
-- | The /concrete/ 'JobHandle' in use with our 'GargM' (production) monad. Its
-- constructor it's not exported, to not leak internal details of its implementation.
...
...
@@ -297,7 +299,9 @@ data DevEnv = DevEnv
makeLenses
''
D
evEnv
instance
CET
.
HasCentralExchangeNotification
DevEnv
where
ce_notify
m
=
liftBase
$
CE
.
notify
m
ce_notify
m
=
do
nc
<-
asks
(
view
dev_env_config
)
liftBase
$
CE
.
notify
(
_gc_notifications_config
nc
)
m
-- | Our /mock/ job handle.
data
DevJobHandle
=
DevJobHandle
...
...
src/Gargantext/API/Admin/Settings.hs
View file @
6d6384ff
...
...
@@ -207,8 +207,8 @@ newEnv logger port settingsFile@(SettingsFile sf) = do
&
Jobs
.
l_jsIDTimeout
.~
(
fromIntegral
$
config_env
^.
hasConfig
^.
gc_js_id_timeout
)
!
jobs_env
<-
Jobs
.
newJobEnv
jobs_settings
prios'
manager_env
!
central_exchange
<-
forkIO
CE
.
gServer
!
dispatcher
<-
D
.
dispatcher
!
central_exchange
<-
forkIO
$
CE
.
gServer
(
_gc_notifications_config
config_env
)
!
dispatcher
<-
D
.
dispatcher
(
_gc_notifications_config
config_env
)
{- An 'Env' by default doesn't have strict fields, but when constructing one in production
we want to force them to WHNF to avoid accumulating unnecessary thunks.
...
...
src/Gargantext/Core/AsyncUpdates/CentralExchange.hs
View file @
6d6384ff
...
...
@@ -20,10 +20,12 @@ import Control.Concurrent.Async qualified as Async
import
Control.Concurrent.STM.TChan
qualified
as
TChan
import
Data.Aeson
qualified
as
Aeson
import
Data.ByteString.Lazy
qualified
as
BSL
import
Data.Text
qualified
as
T
import
Data.Text.Encoding
qualified
as
TE
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
import
Gargantext.Core.
AsyncUpdates.Constants
(
ceBind
,
ceConnect
,
dispatcherConnect
)
import
Gargantext.Core.
Config.Types
(
NotificationsConfig
(
..
)
)
import
Gargantext.Prelude
import
Gargantext.System.Logging
(
LogLevel
(
DEBUG
),
withLogger
,
logMsg
)
import
Gargantext.System.Logging
(
LogLevel
(
..
),
withLogger
,
logMsg
)
import
Nanomsg
(
Pull
(
..
),
Push
(
..
),
bind
,
connect
,
recvMalloc
,
send
,
withSocket
)
{-
...
...
@@ -39,12 +41,12 @@ with many users having updates.
-}
gServer
::
IO
()
gServer
=
do
gServer
::
NotificationsConfig
->
IO
()
gServer
(
NotificationsConfig
{
..
})
=
do
withSocket
Pull
$
\
s
->
do
withSocket
Push
$
\
s_dispatcher
->
do
_
<-
bind
s
ceB
ind
_
<-
connect
s_dispatcher
dispatcherC
onnect
_
<-
bind
s
$
T
.
unpack
_nc_central_exchange_b
ind
_
<-
connect
s_dispatcher
$
T
.
unpack
_nc_dispatcher_c
onnect
tChan
<-
TChan
.
newTChanIO
...
...
@@ -53,9 +55,11 @@ gServer = do
-- | the 'tChan' and calls Dispatcher accordingly. This is to
-- | make reading nanomsg as fast as possible.
void
$
Async
.
concurrently
(
worker
s_dispatcher
tChan
)
$
do
withLogger
()
$
\
ioLogger
->
do
forever
$
do
-- putText "[central_exchange] receiving"
r
<-
recvMalloc
s
1024
r
<-
recvMalloc
s
4096
logMsg
ioLogger
INFO
$
"[central_exchange] received: "
<>
show
r
-- C.putStrLn $ "[central_exchange] " <> r
atomically
$
TChan
.
writeTChan
tChan
r
where
...
...
@@ -69,7 +73,7 @@ gServer = do
-- send the same message that we received
send
s_dispatcher
r
Just
(
UpdateTreeFirstLevel
node_id
)
->
do
logMsg
ioLogger
DEBUG
$
"[central_exchange] update tree: "
<>
show
node_id
logMsg
ioLogger
INFO
$
"[central_exchange] update tree: "
<>
show
node_id
-- putText $ "[central_exchange] sending that to the dispatcher: " <> show node_id
-- To make this more robust, use withAsync so we don't
-- block the main thread (send is blocking)
...
...
@@ -89,10 +93,12 @@ gServer = do
_
->
logMsg
ioLogger
DEBUG
$
"[central_exchange] unknown message"
notify
::
CEMessage
->
IO
()
notify
ceMessage
=
do
notify
::
NotificationsConfig
->
CEMessage
->
IO
()
notify
(
NotificationsConfig
{
_nc_central_exchange_connect
})
ceMessage
=
do
Async
.
withAsync
(
pure
()
)
$
\
_
->
do
withSocket
Push
$
\
s
->
do
_
<-
connect
s
ceC
onnect
_
<-
connect
s
$
T
.
unpack
_nc_central_exchange_c
onnect
let
str
=
Aeson
.
encode
ceMessage
withLogger
()
$
\
ioLogger
->
logMsg
ioLogger
INFO
$
"[central_exchange] sending: "
<>
(
T
.
unpack
$
TE
.
decodeUtf8
$
BSL
.
toStrict
str
)
send
s
$
BSL
.
toStrict
str
src/Gargantext/Core/AsyncUpdates/Constants.hs
deleted
100644 → 0
View file @
9e4f7476
{-|
Module : Gargantext.Core.AsyncUpdates.Constants
Description : Various constants
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341
Docs:
https://dev.sub.gargantext.org/#/share/Notes/187918
-}
module
Gargantext.Core.AsyncUpdates.Constants
where
import
Prelude
qualified
-- NOTE IDP is fast and we're on local network so it shouldn't be a
-- problem with dropping packets. Otherwise, use TCP
-- https://nanomsg.org
-- | Bind address for central exchange (for tcp: tcp://*:5560)
ceBind
::
Prelude
.
String
ceBind
=
"ipc:///tmp/central-exchange.ipc"
-- ceBind = "tcp://*:5560"
-- | Connect address for central exchange (for tcp: tcp://localhost:5560)
ceConnect
::
Prelude
.
String
ceConnect
=
"ipc:///tmp/central-exchange.ipc"
-- ceConnect = "tcp://localhost:5560"
-- | Bind address for dispatcher (for tcp: tcp://*:5561)
dispatcherBind
::
Prelude
.
String
dispatcherBind
=
"ipc:///tmp/dispatcher.ipc"
-- dispatcherBind = "tcp://*:5561"
-- | Connect address for dispatcher (for tcp: tcp://localhost:5561)
dispatcherConnect
::
Prelude
.
String
dispatcherConnect
=
"ipc:///tmp/dispatcher.ipc"
-- dispatcherConnect = "tcp://localhost:5561"
src/Gargantext/Core/AsyncUpdates/Dispatcher.hs
View file @
6d6384ff
...
...
@@ -23,10 +23,11 @@ import Control.Concurrent.STM.TChan qualified as TChan
import
Control.Concurrent.Throttle
(
throttle
)
import
Data.Aeson
qualified
as
Aeson
import
Data.ByteString.Lazy
qualified
as
BSL
import
Data.Text
qualified
as
T
import
DeferredFolds.UnfoldlM
qualified
as
UnfoldlM
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
qualified
as
CETypes
import
Gargantext.Core.AsyncUpdates.Constants
as
AUConstants
import
Gargantext.Core.AsyncUpdates.Dispatcher.Types
import
Gargantext.Core.Config.Types
(
NotificationsConfig
(
..
))
import
Gargantext.Prelude
import
Gargantext.System.Logging
(
LogLevel
(
DEBUG
),
withLogger
,
logMsg
)
import
Nanomsg
(
Pull
(
..
),
bind
,
recvMalloc
,
withSocket
)
...
...
@@ -44,13 +45,13 @@ Dispatcher is a service, which provides couple of functionalities:
-}
dispatcher
::
IO
Dispatcher
dispatcher
=
do
dispatcher
::
NotificationsConfig
->
IO
Dispatcher
dispatcher
nc
=
do
subscriptions
<-
SSet
.
newIO
-- let server = wsServer authSettings subscriptions
d_ce_listener
<-
forkIO
(
dispatcherListener
subscriptions
)
d_ce_listener
<-
forkIO
(
dispatcherListener
nc
subscriptions
)
pure
$
Dispatcher
{
d_subscriptions
=
subscriptions
-- , d_ws_server = server
...
...
@@ -61,10 +62,10 @@ dispatcher = do
-- | This is a nanomsg socket listener. We want to read the messages
-- | as fast as possible and then process them gradually in a separate
-- | thread.
dispatcherListener
::
SSet
.
Set
Subscription
->
IO
()
dispatcherListener
subscriptions
=
do
dispatcherListener
::
NotificationsConfig
->
SSet
.
Set
Subscription
->
IO
()
dispatcherListener
(
NotificationsConfig
{
_nc_dispatcher_bind
})
subscriptions
=
do
withSocket
Pull
$
\
s
->
do
_
<-
bind
s
AUConstants
.
dispatcherB
ind
_
<-
bind
s
$
T
.
unpack
_nc_dispatcher_b
ind
tChan
<-
TChan
.
newTChanIO
...
...
src/Gargantext/Core/AsyncUpdates/Dispatcher/Types.hs
View file @
6d6384ff
...
...
@@ -34,7 +34,6 @@ import Gargantext.API.Admin.Orchestrator.Types (JobLog)
import
Gargantext.API.Admin.Types
(
jwtSettings
,
Settings
,
jwtSettings
)
import
Gargantext.API.Prelude
(
IsGargServer
)
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
qualified
as
CETypes
import
Gargantext.Core.AsyncUpdates.Constants
as
AUConstants
import
Gargantext.Core.Types
(
NodeId
,
UserId
)
import
Gargantext.Prelude
import
GHC.Conc
(
TVar
,
newTVarIO
,
readTVar
,
writeTVar
)
...
...
src/Gargantext/Core/Config.hs
View file @
6d6384ff
...
...
@@ -39,6 +39,7 @@ module Gargantext.Core.Config (
,
gc_mail_config
,
gc_database_config
,
gc_nlp_config
,
gc_notifications_config
,
mkProxyUrl
)
where
...
...
@@ -88,6 +89,7 @@ data GargConfig = GargConfig { _gc_backend_name :: !T.Text
,
_gc_mail_config
::
!
MailConfig
,
_gc_database_config
::
!
PSQL
.
ConnectInfo
,
_gc_nlp_config
::
!
NLPConfig
,
_gc_notifications_config
::
!
NotificationsConfig
}
deriving
(
Generic
,
Show
)
...
...
@@ -104,6 +106,7 @@ instance FromValue GargConfig where
frames
<-
reqKeyOf
"external"
$
parseTableFromValue
$
reqKey
"frames"
jobs
<-
reqKey
"jobs"
apis
<-
reqKey
"apis"
_gc_notifications_config
<-
reqKey
"notifications"
return
$
GargConfig
{
_gc_backend_name
=
_fc_backend_name
,
_gc_url
=
_fc_url
,
_gc_url_backend_api
=
_fc_url_backend_api
...
...
@@ -124,7 +127,8 @@ instance FromValue GargConfig where
,
_gc_frontend_config
,
_gc_mail_config
,
_gc_database_config
=
unTOMLConnectInfo
db_config
,
_gc_nlp_config
}
,
_gc_nlp_config
,
_gc_notifications_config
}
...
...
src/Gargantext/Core/Config/Types.hs
View file @
6d6384ff
...
...
@@ -23,6 +23,7 @@ module Gargantext.Core.Config.Types
,
FrontendConfig
(
..
)
,
JobsConfig
(
..
)
,
APIsConfig
(
..
)
,
NotificationsConfig
(
..
)
,
SecretsConfig
(
..
)
,
corsUseOriginsForHosts
...
...
@@ -186,3 +187,25 @@ instance FromValue APIsConfig where
_ac_pubmed_api_key
<-
reqKeyOf
"pubmed"
$
parseTableFromValue
$
reqKey
"api_key"
_ac_epo_api_url
<-
reqKeyOf
"epo"
$
parseTableFromValue
$
reqKey
"api_url"
return
$
APIsConfig
{
..
}
data
NotificationsConfig
=
NotificationsConfig
{
_nc_central_exchange_bind
::
!
T
.
Text
,
_nc_central_exchange_connect
::
!
T
.
Text
,
_nc_dispatcher_bind
::
!
T
.
Text
,
_nc_dispatcher_connect
::
!
T
.
Text
}
deriving
(
Show
,
Eq
)
instance
FromValue
NotificationsConfig
where
fromValue
=
parseTableFromValue
$
do
(
_nc_central_exchange_bind
,
_nc_central_exchange_connect
)
<-
reqKeyOf
"central-exchange"
$
parseTableFromValue
$
do
b
<-
reqKey
"bind"
c
<-
reqKey
"connect"
pure
(
b
,
c
)
(
_nc_dispatcher_bind
,
_nc_dispatcher_connect
)
<-
reqKeyOf
"dispatcher"
$
parseTableFromValue
$
do
b
<-
reqKey
"bind"
c
<-
reqKey
"connect"
pure
(
b
,
c
)
return
$
NotificationsConfig
{
..
}
test-data/gargantext-settings.toml
deleted
100644 → 0
View file @
9e4f7476
[cors]
allowed-origins
=
[
"https://demo.gargantext.org"
,
"https://formation.gargantext.org"
,
"https://academia.sub.gargantext.org"
,
"https://cnrs.gargantext.org"
,
"https://imt.sub.gargantext.org"
,
"https://helloword.gargantext.org"
,
"https://complexsystems.gargantext.org"
,
"https://europa.gargantext.org"
,
"https://earth.sub.gargantext.org"
,
"https://health.sub.gargantext.org"
,
"https://msh.sub.gargantext.org"
,
"https://dev.sub.gargantext.org"
,
"http://localhost:8008"
]
use-origins-for-hosts
=
true
[microservices.proxy]
port
=
8009
enabled
=
false
test-data/test_config.toml
View file @
6d6384ff
...
...
@@ -58,6 +58,11 @@ from = ""
login_type
=
"Normal"
[notifications]
central-exchange
=
{
bind
=
"tcp://*:15560"
,
connect
=
"tcp://localhost:15560"
}
dispatcher
=
{
bind
=
"tcp://*:15561"
,
connect
=
"tcp://localhost:15561"
}
[nlp]
EN
=
"corenlp://localhost:9000"
FR
=
"spacy://localhost:8001"
...
...
test/Test/API.hs
View file @
6d6384ff
module
Test.API
where
import
Gargantext.Core.Config.Types
(
NotificationsConfig
)
import
Prelude
import
Test.Hspec
import
qualified
Test.API.Authentication
as
Auth
...
...
@@ -10,8 +11,8 @@ import qualified Test.API.Notifications as Notifications
import
qualified
Test.API.Private
as
Private
import
qualified
Test.API.UpdateList
as
UpdateList
tests
::
Spec
tests
=
describe
"API"
$
do
tests
::
NotificationsConfig
->
Spec
tests
_nc
=
describe
"API"
$
do
Auth
.
tests
Private
.
tests
GraphQL
.
tests
...
...
@@ -19,4 +20,4 @@ tests = describe "API" $ do
UpdateList
.
tests
-- | TODO This would work if I managed to get forking dispatcher &
-- exchange listeners properly
-- Notifications.tests
-- Notifications.tests
nc
test/Test/API/Notifications.hs
View file @
6d6384ff
...
...
@@ -18,12 +18,13 @@ module Test.API.Notifications (
)
where
import
Control.Concurrent
(
forkIO
,
killThread
,
threadDelay
)
import
Control.Concurrent.STM.T
Chan
qualified
as
TChan
import
Control.Concurrent.STM.T
Var
qualified
as
TVar
import
Control.Monad.STM
(
atomically
)
import
Data.Aeson
qualified
as
Aeson
import
Gargantext.Core.AsyncUpdates.CentralExchange
qualified
as
CE
import
Gargantext.Core.AsyncUpdates.CentralExchange.Types
qualified
as
CET
import
Gargantext.Core.AsyncUpdates.Dispatcher.Types
qualified
as
DT
import
Gargantext.Core.Config.Types
(
NotificationsConfig
(
..
))
import
Network.WebSockets.Client
qualified
as
WS
import
Network.WebSockets.Connection
qualified
as
WS
import
Prelude
...
...
@@ -34,41 +35,47 @@ import Test.Instances ()
import
Text.RawString.QQ
(
r
)
tests
::
Spec
tests
=
sequential
$
aroundAll
withTestDBAndPort
$
do
tests
::
NotificationsConfig
->
Spec
tests
nc
=
sequential
$
aroundAll
withTestDBAndPort
$
do
describe
"Dispatcher, Central Exchange, WebSockets"
$
do
it
"simple WS notification works"
$
\
((
_testEnv
,
port
),
_
)
->
do
t
chan
<-
TChan
.
newTChanIO
t
var
<-
TVar
.
newTVarIO
Nothing
-- setup a websocket connection
let
wsConnect
=
do
putStrLn
$
"Creating WS client (port "
<>
show
port
<>
")"
WS
.
runClient
"127.0.0.1"
port
"/ws"
$
\
conn
->
do
WS
.
sendTextData
conn
$
Aeson
.
encode
(
DT
.
WSSubscribe
$
DT
.
UpdateTree
0
)
d
<-
WS
.
receiveData
conn
atomically
$
TChan
.
writeTChan
tchan
(
Aeson
.
eitherDecode
d
)
putStrLn
(
"received: "
<>
show
d
)
atomically
$
TVar
.
writeTVar
tvar
(
Aeson
.
decode
d
)
putStrLn
"After WS client"
-- wait a bit to settle
putStrLn
"settling a bit initially"
threadDelay
1000000
threadDelay
(
500
*
millisecond
)
putStrLn
"forking wsConnection"
wsConnection
<-
forkIO
$
wsConnect
-- wait a bit to connect
threadDelay
1000000
threadDelay
(
500
*
millisecond
)
putStrLn
"settling a bit for connection"
threadDelay
1000000
threadDelay
(
500
*
millisecond
)
let
msg
=
CET
.
UpdateTreeFirstLevel
0
putStrLn
"Notifying CE"
CE
.
notify
msg
CE
.
notify
nc
msg
threadDelay
(
500
*
millisecond
)
putStrLn
"Reading tvar with timeout"
d
<-
T
imeout
.
timeout
1000000
(
atomically
$
TChan
.
readTChan
tchan
)
d
<-
T
Var
.
readTVarIO
tvar
putStrLn
"Killing wsConnection thread"
killThread
wsConnection
putStrLn
"Checking d"
d
`
shouldBe
`
(
Just
$
Right
msg
)
d
`
shouldBe
`
(
Just
msg
)
millisecond
::
Int
millisecond
=
1000
test/drivers/hspec/Main.hs
View file @
6d6384ff
...
...
@@ -10,6 +10,7 @@ import Data.Text (isInfixOf)
import
Gargantext.Core.AsyncUpdates.CentralExchange
qualified
as
CE
import
Gargantext.Core.AsyncUpdates.Dispatcher
qualified
as
D
import
Gargantext.Core.AsyncUpdates.Dispatcher.Types
qualified
as
DT
import
Gargantext.Core.Config.Types
(
NotificationsConfig
(
..
))
import
Shelly
hiding
(
FilePath
)
import
System.IO
import
System.Process
...
...
@@ -42,15 +43,21 @@ stopCoreNLPServer :: ProcessHandle -> IO ()
stopCoreNLPServer
=
interruptProcessGroupOf
startNotifications
::
IO
(
ThreadId
,
DT
.
Dispatcher
)
nc
::
NotificationsConfig
nc
=
NotificationsConfig
{
_nc_central_exchange_bind
=
"tcp://*:15560"
,
_nc_central_exchange_connect
=
"tcp://localhost:15560"
,
_nc_dispatcher_bind
=
"tcp://*:15561"
,
_nc_dispatcher_connect
=
"tcp://localhost:15561"
}
startNotifications
::
IO
(
NotificationsConfig
,
ThreadId
,
DT
.
Dispatcher
)
startNotifications
=
do
central_exchange
<-
forkIO
CE
.
gServer
dispatcher
<-
D
.
dispatcher
central_exchange
<-
forkIO
$
CE
.
gServer
nc
dispatcher
<-
D
.
dispatcher
nc
pure
(
central_exchange
,
dispatcher
)
pure
(
nc
,
central_exchange
,
dispatcher
)
stopNotifications
::
(
ThreadId
,
DT
.
Dispatcher
)
->
IO
()
stopNotifications
(
central_exchange
,
dispatcher
)
=
do
stopNotifications
::
(
NotificationsConfig
,
ThreadId
,
DT
.
Dispatcher
)
->
IO
()
stopNotifications
(
_nc
,
central_exchange
,
dispatcher
)
=
do
killThread
central_exchange
killThread
$
DT
.
d_ce_listener
dispatcher
...
...
@@ -70,9 +77,9 @@ main = do
hSetBuffering
stdout
NoBuffering
-- TODO Ideally remove start/stop notifications and use
-- Test/API/Setup to initialize this in env
bracket
startNotifications
stopNotifications
$
\
_
->
do
bracket
startNotifications
stopNotifications
$
\
(
nc'
,
_
,
_
)
->
do
bracket
startCoreNLPServer
stopCoreNLPServer
$
\
_
->
hspec
$
do
API
.
tests
API
.
tests
nc'
ReverseProxy
.
tests
DB
.
tests
DB
.
nodeStoryTests
Przemyslaw Kaminski
@cgenie
mentioned in commit
5660aec0
·
Oct 08, 2024
mentioned in commit
5660aec0
mentioned in commit 5660aec07ec5a0a0a5468f440092c1a8f57a864e
Toggle commit list
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