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
991c637c
Verified
Commit
991c637c
authored
Jun 17, 2024
by
Przemyslaw Kaminski
1
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[refactor] openalex fix, refactoring, fix dispatcher logging
parent
5bf220f1
Pipeline
#6239
failed with stages
Changes
5
Pipelines
1
Show whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
26 additions
and
22 deletions
+26
-22
cabal.project
cabal.project
+1
-1
Dispatcher.hs
src/Gargantext/Core/AsyncUpdates/Dispatcher.hs
+16
-12
Multi.hs
src/Gargantext/Core/Text/Terms/Multi.hs
+1
-1
TFICF.hs
src/Gargantext/Database/Action/Metrics/TFICF.hs
+2
-2
Map.hs
src/Gargantext/Utils/Jobs/Map.hs
+6
-6
No files found.
cabal.project
View file @
991c637c
...
...
@@ -108,7 +108,7 @@ source-repository-package
source
-
repository
-
package
type
:
git
location
:
https
://
gitlab
.
iscpif
.
fr
/
gargantext
/
crawlers
/
openalex
.
git
tag
:
c
eb8f2cebd4890b6d9d151ab01ee14e925bc0499
tag
:
c
2114adb0382770e419e5a7ae1b3a1ee5b09ee50
source
-
repository
-
package
type
:
git
...
...
src/Gargantext/Core/AsyncUpdates/Dispatcher.hs
View file @
991c637c
...
...
@@ -39,6 +39,7 @@ import Gargantext.Core.AsyncUpdates.Constants as AUConstants
import
Gargantext.Core.AsyncUpdates.Dispatcher.Types
import
Gargantext.Core.Types
(
NodeId
,
UserId
)
import
Gargantext.Prelude
import
Gargantext.System.Logging
(
LogLevel
(
DEBUG
),
withLogger
,
logMsg
)
-- import Gargantext.Utils.Jobs.Monad (MonadJobStatus(getLatestJobStatus))
import
GHC.Conc
(
TVar
,
newTVarIO
,
readTVar
,
writeTVar
)
import
Nanomsg
(
Pull
(
..
),
bind
,
recvMalloc
,
withSocket
)
...
...
@@ -149,18 +150,19 @@ wsServer = WSAPI { wsAPIServer = streamData }
threadDelay
$
10
*
1000000
wsLoop
authSettings
subscriptions
ws
=
flip
finally
disconnect
$
do
putText
"[wsLoop] connecting"
wsLoop'
CUPublic
withLogger
()
$
\
ioLogger
->
do
logMsg
ioLogger
DEBUG
"[wsLoop] connecting"
wsLoop'
CUPublic
ioLogger
where
wsLoop'
user
=
do
wsLoop'
user
ioLogger
=
do
dm
<-
WS
.
receiveDataMessage
(
wsConn
ws
)
newUser
<-
case
dm
of
WS
.
Text
dm'
_
->
do
case
Aeson
.
decode
dm'
of
Nothing
->
do
putText
$
"[wsLoop] unknown message: "
<>
show
dm'
logMsg
ioLogger
DEBUG
$
"[wsLoop] unknown message: "
<>
show
dm'
return
user
Just
(
WSSubscribe
topic
)
->
do
-- TODO Fix s_connected_user based on header
...
...
@@ -181,7 +183,7 @@ wsServer = WSAPI { wsAPIServer = streamData }
let
jwtS
=
authSettings
^.
jwtSettings
mUser
<-
liftBase
$
verifyJWT
jwtS
(
encodeUtf8
token
)
putText
$
"[wsLoop] authorized user: "
<>
show
mUser
logMsg
ioLogger
DEBUG
$
"[wsLoop] authorized user: "
<>
show
mUser
-- TODO Update my subscriptions!
...
...
@@ -190,13 +192,14 @@ wsServer = WSAPI { wsAPIServer = streamData }
-- TODO Update my subscriptions!
pure
CUPublic
_
->
do
putText
"[wsLoop] binary ws messages not supported"
logMsg
ioLogger
DEBUG
"[wsLoop] binary ws messages not supported"
return
user
wsLoop'
newUser
wsLoop'
newUser
ioLogger
disconnect
=
do
putText
"[wsLoop] disconnecting..."
withLogger
()
$
\
ioLogger
->
do
logMsg
ioLogger
DEBUG
"[wsLoop] disconnecting..."
_ss
<-
removeSubscriptionsForWSKey
subscriptions
ws
-- putText $ "[wsLoop] subscriptions: " <> show (show <$> ss)
return
()
...
...
@@ -230,7 +233,8 @@ dispatcher_listener subscriptions = do
-- putText $ "[" <> show tId <> "] received a message: " <> decodeUtf8 r
case
Aeson
.
decode
(
BSL
.
fromStrict
r
)
of
Nothing
->
putText
"[dispatcher_listener] unknown message from central exchange"
Nothing
->
withLogger
()
$
\
ioL
->
logMsg
ioL
DEBUG
"[dispatcher_listener] unknown message from central exchange"
Just
ceMessage
->
do
-- putText $ "[dispatcher_listener] received message: " <> show ceMessage
-- subs <- atomically $ readTVar subscriptions
...
...
src/Gargantext/Core/Text/Terms/Multi.hs
View file @
991c637c
...
...
@@ -36,7 +36,7 @@ multiterms nsc l txt = do
let
txt'
=
cleanTextForNLP
txt
if
txt'
==
""
then
do
printDebug
"[G.C.T.Terms.Multi] becomes empty after cleanTextForNLP"
txt
--
printDebug "[G.C.T.Terms.Multi] becomes empty after cleanTextForNLP" txt
pure
[]
else
do
ret
<-
multiterms'
tokenTag2terms
l
txt'
...
...
src/Gargantext/Database/Action/Metrics/TFICF.hs
View file @
991c637c
...
...
@@ -70,8 +70,8 @@ getTficf_withSample cId mId nt = do
<$>
getOccByNgramsOnlyFast_withSample
mId
countGlobal
nt
(
HM
.
keys
mapTextDoubleLocal
)
printDebug
"[getTficf_withSample] mapTextDoubleLocal: "
mapTextDoubleLocal
printDebug
"[getTficf_withSample] mapTextDoubleGlobal: "
mapTextDoubleGlobal
--
printDebug "[getTficf_withSample] mapTextDoubleLocal: " mapTextDoubleLocal
--
printDebug "[getTficf_withSample] mapTextDoubleGlobal: " mapTextDoubleGlobal
--printDebug "getTficf_withSample" (mapTextDoubleLocal, mapTextDoubleGlobal, countLocal, countGlobal)
pure
$
HM
.
mapWithKey
(
\
t
n
->
...
...
src/Gargantext/Utils/Jobs/Map.hs
View file @
991c637c
...
...
@@ -24,7 +24,7 @@ module Gargantext.Utils.Jobs.Map (
)
where
import
Control.Concurrent
import
Control.Concurrent.Async
import
Control.Concurrent.Async
qualified
as
Async
import
Control.Concurrent.STM
import
Control.Exception
import
Control.Monad
...
...
@@ -71,7 +71,7 @@ data QueuedJob w r where
-- | A running job points to the async computation for the job and provides a
-- function to peek at the current logs.
data
RunningJob
w
a
=
RunningJob
{
rjAsync
::
Async
a
{
rjAsync
::
Async
.
Async
a
,
rjGetLog
::
IO
w
}
...
...
@@ -183,18 +183,18 @@ waitJobDone jid rj (JobMap mvar) = do
runJ
::
Monoid
w
=>
QueuedJob
w
a
->
IO
(
RunningJob
w
a
)
runJ
(
QueuedJob
a
f
)
=
do
logs
<-
newTVarIO
mempty
act
<-
async
$
f
a
(
jobLog
logs
)
act
<-
Async
.
async
$
f
a
(
jobLog
logs
)
let
readLogs
=
readTVarIO
logs
pure
(
RunningJob
act
readLogs
)
-- | Wait for a running job to return (blocking).
waitJ
::
RunningJob
w
a
->
IO
(
Either
SomeException
a
)
waitJ
(
RunningJob
act
_
)
=
waitCatch
act
waitJ
(
RunningJob
act
_
)
=
Async
.
waitCatch
act
-- | Poll a running job to see if it's done.
pollJ
::
RunningJob
w
a
->
IO
(
Maybe
(
Either
SomeException
a
))
pollJ
(
RunningJob
act
_
)
=
poll
act
pollJ
(
RunningJob
act
_
)
=
Async
.
poll
act
-- | Kill a running job by cancelling the action.
killJ
::
RunningJob
w
a
->
IO
()
killJ
(
RunningJob
act
_
)
=
cancel
act
killJ
(
RunningJob
act
_
)
=
Async
.
cancel
act
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