Skip to content

P
purescript-gargantext
Verified Commit 3e499383 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

Merge remote-tracking branch 'origin/dev' into 304-dev-toml-config-rewrite

parents 34476655 9144bad9
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 2178 additions and 409 deletions
CHANGELOG.md
View file @ 3e499383
## Version 0.0.7.2
* [FRONT][FEAT][Graph Explorer Legend (#683)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/683)
* [FRONT][FIX][[Graph explorer] Search and associated documents (#262)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/262)
* [BACK][FIX][Terms are calculated over all documents, even those in trash (#385)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/385)
* [BACK][FIX][Improve document search (and better error reporting) (#265)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/265)
* [BACK][FEAT][Add websockets support (#341)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/341)
## Version 0.0.7.1.16
* [BACK][FI][API with Open Alex seems down (#379)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/379)
......
README.md
View file @ 3e499383
......@@ -317,3 +317,14 @@ Maybe you need to restore the gargantua password
$ ALTER ROLE gargantua PASSWORD 'yourPasswordIn_gargantext.ini'
```
Maybe you need to change the port to 5433 for database connection in your gargantext.ini file.
## `haskell-language-server`
If you want to use `haskell-language-server` for GHC 9.4.7, install it
with `ghcup`:
```shell
ghcup compile hls --version 2.7.0.0 --ghc 9.4.7
```
https://haskell-language-server.readthedocs.io/en/latest/installation.html
bench/Main.hs
View file @ 3e499383
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import Control.DeepSeq
......
bin/gargantext-central-exchange/Main.hs 0 → 100644
View file @ 3e499383
{-|
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
bin/gargantext-cli/CLI/Invitations.hs
View file @ 3e499383
......@@ -23,6 +23,7 @@ import Gargantext.API.Errors.Types
import Gargantext.API.Node () -- instances only
import Gargantext.API.Node.Share qualified as Share
import Gargantext.API.Node.Share.Types qualified as Share
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.Types
......@@ -36,7 +37,10 @@ invitationsCLI :: InvitationsArgs -> IO ()
invitationsCLI (InvitationsArgs settingsPath user node_id email) = do
-- _cfg <- readConfig settingsPath
let invite :: (HasSettings env, CmdRandom env BackendInternalError m, HasNLPServer env) => m Int
let invite :: ( HasSettings env
, CmdRandom env BackendInternalError m
, HasNLPServer env
, CET.HasCentralExchangeNotification env ) => m Int
invite = Share.api (UserName $ cs user) node_id (Share.ShareTeamParams $ cs email)
withDevEnv settingsPath $ \env -> do
......
bin/gargantext-cli/CLI/Phylo/Common.hs
View file @ 3e499383
{-# LANGUAGE OverloadedStrings #-}
module CLI.Phylo.Common where
import Control.Concurrent.Async (mapConcurrently)
......
bin/gargantext-cli/CLI/Phylo/Profile.hs
View file @ 3e499383
{-# LANGUAGE OverloadedStrings #-}
module CLI.Phylo.Profile where
import CLI.Phylo.Common
......
bin/gargantext-cli/CLI/Server/Routes.hs
View file @ 3e499383
......@@ -18,6 +18,7 @@ import Options.Applicative
import Prelude
import Servant.API
import Servant.API.Routes
import Servant.API.WebSocket qualified as WS (WebSocketPending)
import Servant.Auth qualified as Servant
routesCmd :: Mod CommandFields CLI
......@@ -42,6 +43,9 @@ export_p = CLIR_export <$>
instance HasRoutes api => HasRoutes (Servant.Auth xs a :> api) where
getRoutes = getRoutes @api
instance HasRoutes WS.WebSocketPending where
getRoutes = []
instance HasRoutes Raw where
getRoutes = []
......
bin/install
View file @ 3e499383
......@@ -4,5 +4,5 @@ echo "GarganText, build, install, test and documentation"
nix-shell --run "cabal update \\
&& cabal v2-build --ghc-options=-O2 \\
&& cabal --overwrite-policy=always install \\
&& cabal v2-test --test-show-details=streaming \\
&& cabal v2-test \\
&& cabal haddock"
bin/track_haskell_deps.hs
View file @ 3e499383
......@@ -12,11 +12,8 @@ stack exec ghc -- --make -O2 -threaded scripts/haskell/dependencies.hs
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ViewPatterns #-}
module Main where
......
bin/update-project-dependencies
View file @ 3e499383
......@@ -21,6 +21,7 @@ fi
expected_cabal_project_hash="72e706e2a48ab404346b7edae38b04207e31821416f56328d324f743e7a5756a"
expected_cabal_project_freeze_hash="d51d800b35946a4d51c75aab21e3b54fde500f54e4a1565a4d21d71aaae34bef"
cabal --store-dir=$STORE_DIR v2-build --dry-run
cabal2stack --system-ghc --allow-newer --resolver lts-21.17 --resolver-file devops/stack/lts-21.17.yaml -o stack.yaml
cabal --store-dir=$STORE_DIR v2-freeze
......
cabal.project
View file @ 3e499383
......@@ -29,7 +29,7 @@ source-repository-package
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/opaleye-textsearch.git
tag: cb07b604bfb7a22aa21dd8918de5cb65c8a4bdf1
tag: 04b5c9044fef44393b66bffa258ca0b0f59c1087
source-repository-package
type: git
......@@ -165,6 +165,16 @@ source-repository-package
location: https://github.com/robstewart57/rdf4h.git
tag: 4fd2edf30c141600ffad6d730cc4c1c08a6dbce4
source-repository-package
type: git
location: https://github.com/garganscript/nanomsg-haskell
tag: 23be4130804d86979eaee5caffe323a1c7f2b0d6
-- source-repository-package
-- type: git
-- location: https://github.com/jimenezrick/nng-haskell
-- tag: 31e52d7bc720e5fb9daf1c1e8bc1fd156d577af2
source-repository-package
type: git
location: https://github.com/adinapoli/http-reverse-proxy.git
......@@ -180,6 +190,12 @@ source-repository-package
location: https://github.com/glguy/toml-parser
tag: toml-parser-2.0.1.0
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/haskell-throttle
tag: 02f5ed9ee2d6cce45161addf945b88bc6adf9059
allow-older: *
allow-newer: *
......
cabal.project.freeze
View file @ 3e499383
......@@ -167,6 +167,7 @@ constraints: any.Cabal ==3.8.1.0,
any.data-time-segment ==0.1.0.0,
any.dec ==0.0.5,
any.deepseq ==1.4.8.0,
any.deferred-folds ==0.9.18.6,
any.dense-linear-algebra ==0.1.0.0,
any.deriving-aeson ==0.2.9,
any.digest ==0.0.1.7,
......@@ -205,8 +206,10 @@ constraints: any.Cabal ==3.8.1.0,
any.filepath ==1.4.2.2,
any.filepattern ==0.1.3,
any.fmt ==0.6.3.0,
any.focus ==1.0.3.2,
any.foldable1-classes-compat ==0.1,
foldable1-classes-compat +tagged,
any.foldl ==1.4.15,
any.formatting ==7.2.0,
formatting +no-double-conversion,
any.free ==5.1.10,
......@@ -250,6 +253,7 @@ constraints: any.Cabal ==3.8.1.0,
any.haskell-lexer ==1.1.1,
any.haskell-src-exts ==1.23.1,
any.haskell-src-meta ==0.8.12,
any.haskell-throttle ==0.1.0.0,
any.hedgehog ==1.2,
any.hgal ==2.0.0.2,
any.hlcm ==0.2.2,
......@@ -330,6 +334,7 @@ constraints: any.Cabal ==3.8.1.0,
libyaml -no-unicode -system-libyaml,
any.lifted-async ==0.10.2.4,
any.lifted-base ==0.2.3.12,
any.list-t ==1.0.5.7,
any.listsafe ==0.1.0.1,
any.llvm-hs ==12.0.0,
llvm-hs -debug -llvm-with-rtti +shared-llvm,
......@@ -377,6 +382,7 @@ constraints: any.Cabal ==3.8.1.0,
any.mtl-compat ==0.2.2,
mtl-compat -two-point-one -two-point-two,
any.mwc-random ==0.15.0.2,
any.nanomsg-haskell ==0.2.4,
any.natural-transformation ==0.4,
any.network ==3.1.4.0,
network -devel,
......@@ -387,7 +393,7 @@ constraints: any.Cabal ==3.8.1.0,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.opaleye ==0.9.6.1,
any.opaleye-textsearch ==0.1.0.0,
any.opaleye-textsearch ==0.2.0.0,
any.openalex ==0.1.0.0,
any.optics-core ==0.4.1.1,
optics-core -explicit-generic-labels,
......@@ -432,6 +438,8 @@ constraints: any.Cabal ==3.8.1.0,
prettyprinter -buildreadme +text,
any.prettyprinter-ansi-terminal ==1.1.3,
any.primitive ==0.8.0.0,
any.primitive-extras ==0.10.1.10,
any.primitive-unlifted ==2.1.0.0,
any.probability ==0.2.8,
probability +splitbase,
any.process ==1.6.17.0,
......@@ -508,6 +516,7 @@ constraints: any.Cabal ==3.8.1.0,
any.servant-swagger ==1.2,
any.servant-swagger-ui ==0.3.5.5.0.0,
any.servant-swagger-ui-core ==0.3.5,
any.servant-websockets ==2.0.0,
any.servant-xml-conduit ==0.1.0.4,
any.shelly ==1.12.1,
shelly -build-examples -lifted,
......@@ -540,7 +549,9 @@ constraints: any.Cabal ==3.8.1.0,
any.stemmer ==0.5.2,
any.stm ==2.5.1.0,
any.stm-chans ==3.0.0.9,
any.stm-containers ==1.2.0.3,
any.stm-delay ==0.1.1.1,
any.stm-hamt ==1.2.0.14,
any.storable-complex ==0.2.3.0,
any.streaming-commons ==0.2.2.6,
streaming-commons -use-bytestring-builder,
......
devops/docker/docker-compose.yaml
View file @ 3e499383
version: '3'
services:
caddy:
image: caddy:alpine
network: host
ports:
- 8108:8108
volumes:
- ./Caddyfile:/etc/caddy/Caddyfile:ro
- ../../purescript-gargantext:/srv/purescript-gargantext:ro
#postgres11:
# #image: 'postgres:latest'
# image: 'postgres:11'
......@@ -36,26 +45,35 @@ services:
- ../dbs:/dbs
- ../postgres/schema.sql:/docker-entrypoint-initdb.d/schema.sql:ro
pgadmin:
image: 'dpage/pgadmin4'
ports:
- 8081:80
environment:
PGADMIN_DEFAULT_EMAIL: admin@localhost.lan
PGADMIN_DEFAULT_PASSWORD: admin
# NOTE: Use dbeaver instead, it's nicer and remembers passwords
# (unlike pgadmin when you remove the docker volume)
# pgadmin:
# image: 'dpage/pgadmin4'
# ports:
# - 8081:80
# environment:
# PGADMIN_DEFAULT_EMAIL: admin@localhost.lan
# PGADMIN_DEFAULT_PASSWORD: admin
depends_on:
- postgres
links:
- postgres
volumes:
- pgadmin:/var/lib/pgadmin
# depends_on:
# - postgres
# links:
# - postgres
# volumes:
# - pgadmin:/var/lib/pgadmin
corenlp:
#image: 'cgenie/corenlp-garg:latest'
image: 'cgenie/corenlp-garg:4.5.4'
ports:
- 9000:9000
# corenlp:
# #image: 'cgenie/corenlp-garg:latest'
# image: 'cgenie/corenlp-garg:4.5.4'
# ports:
# - 9000:9000
# johnsnownlp:
# image: 'johnsnowlabs/nlp-server:latest'
# volumes:
# - js-cache:/home/johnsnowlabs/cache_pretrained
# ports:
# - 5000:5000
volumes:
#garg-pgdata:
......
gargantext.cabal
View file @ 3e499383
......@@ -5,7 +5,7 @@ cabal-version: 3.4
-- see: https://github.com/sol/hpack
name: gargantext
version: 0.0.7.1.16
version: 0.0.7.2
synopsis: Search, map, share
description: Please see README.md
category: Data
......@@ -33,6 +33,7 @@ data-files:
ekg-assets/chart_line_add.png
ekg-assets/cross.png
test-data/ngrams/GarganText_NgramsTerms-QuantumComputing.json
test-data/ngrams/GarganText_DocsList-nodeId-177.json
test-data/ngrams/simple.json
test-data/ngrams/simple.tsv
test-data/phylo/bpa_phylo_test.json
......@@ -67,6 +68,7 @@ common defaults
MultiParamTypeClasses
NamedFieldPuns
NoImplicitPrelude
NumericUnderscores
OverloadedStrings
RankNTypes
RecordWildCards
......@@ -126,6 +128,7 @@ library
Gargantext.API.Ngrams.Types
Gargantext.API.Node
Gargantext.API.Node.Corpus.New
Gargantext.API.Node.Corpus.New.Types
Gargantext.API.Node.Corpus.Types
Gargantext.API.Node.Corpus.Update
Gargantext.API.Node.File
......@@ -162,6 +165,15 @@ library
Gargantext.API.Types
Gargantext.API.Viz.Types
Gargantext.Core
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
Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket
Gargantext.Core.AsyncUpdates.Nanomsg
Gargantext.Core.Config
Gargantext.Core.Config.CORS
Gargantext.Core.Config.Database
......@@ -186,13 +198,14 @@ library
Gargantext.Core.Text.Corpus.API.OpenAlex
Gargantext.Core.Text.Corpus.API.Pubmed
Gargantext.Core.Text.Corpus.Parsers
Gargantext.Core.Text.Corpus.Parsers.TSV
Gargantext.Core.Text.Corpus.Parsers.Date
Gargantext.Core.Text.Corpus.Parsers.Date.Parsec
Gargantext.Core.Text.Corpus.Parsers.TSV
Gargantext.Core.Text.Corpus.Query
Gargantext.Core.Text.List
Gargantext.Core.Text.List.Group.WithStem
Gargantext.Core.Text.List.Formats.TSV
Gargantext.Core.Text.List.Group.WithStem
Gargantext.Core.Text.List.Social
Gargantext.Core.Text.Metrics
Gargantext.Core.Text.Metrics.CharByChar
Gargantext.Core.Text.Metrics.Count
......@@ -294,6 +307,7 @@ library
Gargantext.API.GraphQL.Team
Gargantext.API.GraphQL.TreeFirstLevel
Gargantext.API.GraphQL.Types
Gargantext.API.GraphQL.UnPrefix
Gargantext.API.GraphQL.User
Gargantext.API.GraphQL.UserInfo
Gargantext.API.GraphQL.Utils
......@@ -307,7 +321,6 @@ library
Gargantext.API.Node.Corpus.Export
Gargantext.API.Node.Corpus.Export.Types
Gargantext.API.Node.Corpus.New.File
Gargantext.API.Node.Corpus.New.Types
Gargantext.API.Node.Corpus.Searx
Gargantext.API.Node.Document.Export
Gargantext.API.Node.Document.Export.Types
......@@ -375,7 +388,6 @@ library
Gargantext.Core.Text.List.Group.WithScores
Gargantext.Core.Text.List.Learn
Gargantext.Core.Text.List.Merge
Gargantext.Core.Text.List.Social
Gargantext.Core.Text.List.Social.Find
Gargantext.Core.Text.List.Social.Patch
Gargantext.Core.Text.List.Social.Prelude
......@@ -542,6 +554,7 @@ library
, cryptohash ^>= 0.11.9
, data-time-segment ^>= 0.1.0.0
, deepseq ^>= 1.4.4.0
, deferred-folds >= 0.9.18 && < 0.10
, directory ^>= 1.3.6.0
, discrimination >= 0.5
, ekg-core ^>= 0.1.1.7
......@@ -563,6 +576,7 @@ library
, graphviz ^>= 2999.20.1.0
, hashable ^>= 1.3.0.0
, haskell-igraph ^>= 0.10.4
, haskell-throttle
, hlcm ^>= 0.2.2
, hsinfomap ^>= 0.1
, hsparql ^>= 0.3.8
......@@ -604,11 +618,12 @@ library
, morpheus-graphql-subscriptions >= 0.17.0 && < 0.25
, morpheus-graphql-tests >= 0.17.0 && < 0.25
, mtl ^>= 2.2.2
, nanomsg-haskell >= 0.2.4 && < 0.3
, natural-transformation ^>= 0.4
, network >= 3.1.4.0
, network-uri ^>= 2.6.4.1
, opaleye ^>= 0.9.6.1
, opaleye-textsearch >= 0.1.0.0
, opaleye-textsearch >= 0.2.0.0
, openalex
, pandoc ^>= 2.14.0.3
, parallel ^>= 3.2.2.0
......@@ -659,6 +674,7 @@ library
, servant-swagger >= 1.2
, servant-swagger-ui ^>= 0.3.5.3.5.0
, servant-swagger-ui-core >= 0.3.5
, servant-websockets >= 2.0.0 && < 2.1
, servant-xml-conduit >= 0.1.0.4
, simple-reflect ^>= 0.3.3
, singletons ^>= 2.7
......@@ -667,6 +683,7 @@ library
, split ^>= 0.2.3.4
, stemmer ^>= 0.5.2
, stm ^>= 2.5.0.1
, stm-containers >= 1.2.1 && < 1.3
, stringsearch >= 0.3.6.6
, swagger2 ^>= 2.6
, taggy-lens ^>= 0.1.2
......@@ -754,6 +771,7 @@ executable gargantext-cli
, servant
, servant-auth
, servant-routes < 0.2
, servant-websockets >= 2.0.0 && < 2.1
, shelly
, split ^>= 0.2.3.4
, text ^>= 1.2.4.1
......@@ -784,6 +802,27 @@ executable gargantext-server
, text ^>= 1.2.4.1
, 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:
......@@ -802,6 +841,7 @@ common testDependencies
, crawlerArxiv
, cryptohash
, directory
, epo-api-client
, extra ^>= 1.7.9
, fast-logger ^>= 3.0.5
, fmt
......@@ -840,6 +880,7 @@ common testDependencies
, servant-client-core
, servant-job
, servant-server
, servant-websockets >= 2.0.0 && < 2.1
, shelly >= 1.9 && < 2
, split
, stm ^>= 2.5.0.1
......@@ -864,6 +905,27 @@ common testDependencies
, wai
, wai-extra
, warp
, servant-websockets >= 2.0.0 && < 2.1
, shelly >= 1.9 && < 2
, stm ^>= 2.5.0.1
, streaming-commons
, tasty ^>= 1.4.2.1
, tasty-hspec
, tasty-hunit
, tasty-quickcheck
, tasty-smallcheck
, template-haskell
, text ^>= 1.2.4.1
, time ^>= 1.9.3
, tmp-postgres >= 1.34.1 && < 1.35
, tree-diff
, unliftio
, unordered-containers ^>= 0.2.16.0
, validity ^>= 0.11.0.1
, wai
, wai-extra
, warp
, websockets
test-suite garg-test-tasty
import:
......@@ -872,9 +934,14 @@ test-suite garg-test-tasty
type: exitcode-stdio-1.0
main-is: drivers/tasty/Main.hs
other-modules:
Test.API.Routes
CLI.Phylo.Common
Paths_gargantext
Test.Core.AsyncUpdates
Test.API.Private.Share
Test.API.Authentication
Test.API.Routes
Test.API.Setup
Test.API.UpdateList
Test.Core.Similarity
Test.Core.Text
Test.Core.Text.Corpus.Query
......@@ -889,6 +956,7 @@ test-suite garg-test-tasty
Test.Database.Types
Test.Graph.Clustering
Test.Graph.Distance
Test.Instances
Test.Ngrams.Lang
Test.Ngrams.Lang.En
Test.Ngrams.Lang.Fr
......@@ -909,7 +977,6 @@ test-suite garg-test-tasty
Test.Utils
Test.Utils.Crypto
Test.Utils.Jobs
Paths_gargantext
hs-source-dirs:
test bin/gargantext-cli
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
......@@ -926,6 +993,7 @@ test-suite garg-test-hspec
Test.API.Authentication
Test.API.Errors
Test.API.GraphQL
Test.API.Notifications
Test.API.Private
Test.API.Private.Share
Test.API.Routes
......
nix/pkgs.nix
View file @ 3e499383
......@@ -33,6 +33,10 @@ rec {
];
});
# nng180 = pkgs.nng.overrideAttrs (new: old: rec {
# version = "1.8.0";
# });
igraph_0_10_4 = pkgs.igraph.overrideAttrs (finalAttrs: previousAttrs: {
version = "0.10.4";
......@@ -125,6 +129,8 @@ rec {
igraph_0_10_4
libpqxx
libsodium
nanomsg
# nng180
zeromq
curl
] ++ ( lib.optionals stdenv.isDarwin [
......
shell.nix
View file @ 3e499383
......@@ -2,8 +2,9 @@
let
myBuildInputs = [
pkgs.pkgs.docker-compose
pkgs.pkgs.haskell-language-server
#pkgs.pkgs.haskell-language-server
pkgs.pkgs.stack
pkgs.pkgs.websocat
];
in
pkgs.pkgs.mkShell {
......
src/Gargantext/API.hs
View file @ 3e499383
......@@ -27,7 +27,6 @@ Pouillard (who mainly made it).
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
......@@ -52,7 +51,7 @@ 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.API.Server.Named.EKG
import Gargantext.Core.AsyncUpdates.Constants qualified as AUConstants
import Gargantext.Core.Config.CORS
import Gargantext.Core.Config.MicroServices
import Gargantext.Core.Config.Types (SettingsFile(..))
......@@ -65,12 +64,12 @@ import Network.Wai
import Network.Wai.Handler.Warp hiding (defaultSettings)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.RequestLogger
import Paths_gargantext (getDataDir)
-- import Paths_gargantext (getDataDir)
import Servant hiding (Header)
import Servant.Client.Core.BaseUrl (showBaseUrl)
import System.Clock qualified as Clock
import System.Cron.Schedule qualified as Cron
import System.FilePath
-- import System.FilePath
-- | startGargantext takes as parameters port number and Ini file.
startGargantext :: Mode -> PortNumber -> SettingsFile -> IO ()
......@@ -108,6 +107,9 @@ 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 $ " - WebSocket address........................: " <> "ws://localhost:" <> toUrlPiece mainPort <> "/ws"
putStrLn "=========================================================================================================="
-- | Stops the gargantext server and cancels all the periodic actions
......@@ -183,12 +185,13 @@ makeGargMiddleware crsSettings mode = do
makeApp :: Env -> IO Application
makeApp env = do
(ekgStore, ekgMid) <- newEkgStore api
ekgDir <- (</> "ekg-assets") <$> getDataDir
pure $ ekgMid $ serveWithContext apiWithEkg cfg
(WithEkg { ekgAPI = ekgServer ekgDir ekgStore
, wrappedAPI = server env
})
pure $ serveWithContext api cfg (server env)
-- (ekgStore, ekgMid) <- newEkgStore api
-- ekgDir <- (</> "ekg-assets") <$> getDataDir
-- pure $ ekgMid $ serveWithContext apiWithEkg cfg
-- (WithEkg { ekgAPI = ekgServer ekgDir ekgStore
-- , wrappedAPI = server env
-- })
where
cfg :: Servant.Context AuthContext
cfg = env ^. settings . jwtSettings
......
src/Gargantext/API/Admin/Auth/Types.hs
View file @ 3e499383
......@@ -74,7 +74,7 @@ data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId UserId
data AuthenticatedUser = AuthenticatedUser
{ _auth_node_id :: NodeId
, _auth_user_id :: UserId
} deriving (Generic)
} deriving (Generic, Show, Eq)
makeLenses ''AuthenticatedUser
......
src/Gargantext/API/Admin/EnvTypes.hs
View file @ 3e499383
......@@ -14,6 +14,8 @@ module Gargantext.API.Admin.EnvTypes (
, env_manager
, env_settings
, env_self_url
, env_central_exchange
, env_dispatcher
, menv_firewall
, dev_env_logger
......@@ -36,6 +38,9 @@ import Gargantext.API.Admin.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Job
import Gargantext.API.Prelude (GargM, IsGargServer)
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.AsyncUpdates.Dispatcher.Types (Dispatcher, HasDispatcher(..))
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.NLP (NLPServerMap, HasNLPServer(..))
import Gargantext.Core.NodeStory
......@@ -44,6 +49,7 @@ import Gargantext.Prelude
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Core.Config.Mail (MailConfig)
import Gargantext.System.Logging
import Gargantext.Utils.Jobs.Internal (pollJob)
import Gargantext.Utils.Jobs.Map (LoggerM, J(..), jTask, rjGetLog)
import Gargantext.Utils.Jobs.Monad qualified as Jobs
import Network.HTTP.Client (Manager)
......@@ -51,6 +57,7 @@ import Servant.Client (BaseUrl)
import Servant.Job.Async (HasJobEnv(..), Job)
import Servant.Job.Async qualified as SJ
import Servant.Job.Core qualified
import Servant.Job.Types qualified as SJ
import System.Log.FastLogger qualified as FL
data Mode = Dev | Mock | Prod
......@@ -123,6 +130,8 @@ data Env = Env
, _env_config :: ~GargConfig
, _env_mail :: ~MailConfig
, _env_nlp :: ~NLPServerMap
, _env_central_exchange :: ~ThreadId
, _env_dispatcher :: ~Dispatcher
}
deriving (Generic)
......@@ -152,6 +161,9 @@ instance HasMail Env where
instance HasNLPServer Env where
nlpServer = env_nlp
instance HasDispatcher Env where
hasDispatcher = env_dispatcher
instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
_env = env_scrapers . Servant.Job.Core._env
......@@ -161,6 +173,9 @@ instance HasJobEnv Env JobLog JobLog where
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
-- | The /concrete/ 'JobHandle' in use with our 'GargM' (production) monad. Its
-- constructor it's not exported, to not leak internal details of its implementation.
data ConcreteJobHandle err =
......@@ -180,8 +195,19 @@ mkJobHandle jId = JobHandle jId
-- | Updates the status of a 'JobHandle' by using the input 'updateJobStatus' function.
updateJobProgress :: ConcreteJobHandle err -> (JobLog -> JobLog) -> GargM Env err ()
updateJobProgress ConcreteNullHandle _ = pure ()
updateJobProgress hdl@(JobHandle _ logStatus) updateJobStatus =
Jobs.getLatestJobStatus hdl >>= logStatus . updateJobStatus
updateJobProgress hdl@(JobHandle jId logStatus) updateJobStatus = do
jobLog <- Jobs.getLatestJobStatus hdl
let jobLogNew = updateJobStatus jobLog
logStatus jobLogNew
mJb <- Jobs.findJob jId
case mJb of
Nothing -> pure ()
Just je -> do
-- We use the same endpoint as the one for polling jobs via
-- API. This way we can send the job status directly in the
-- notification
j <- pollJob (Just $ SJ.Limit 1) Nothing jId je
CET.ce_notify $ CET.UpdateJobProgress j
instance Jobs.MonadJobStatus (GargM Env err) where
......@@ -270,6 +296,9 @@ data DevEnv = DevEnv
makeLenses ''DevEnv
instance CET.HasCentralExchangeNotification DevEnv where
ce_notify m = liftBase $ CE.notify m
-- | Our /mock/ job handle.
data DevJobHandle = DevJobHandle
......
src/Gargantext/API/Admin/Orchestrator/Types.hs
View file @ 3e499383
......@@ -11,7 +11,7 @@ import Data.Morpheus.Types ( GQLType, typeOptions )
import Data.Proxy
import Data.Swagger hiding (URL, url, port)
import GHC.Generics hiding (to)
import Gargantext.API.GraphQL.Utils qualified as GQLU
import Gargantext.API.GraphQL.UnPrefix qualified as GQLU
import Gargantext.Core.Types (TODO(..))
import Gargantext.Prelude
import Servant
......@@ -22,12 +22,6 @@ import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
------------------------------------------------------------------------
instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where
arbitrary = panicTrace "TODO"
instance Arbitrary a => Arbitrary (JobOutput a) where
arbitrary = JobOutput <$> arbitrary
-- | Main Types
-- TODO IsidoreAuth
data ExternalAPIs = OpenAlex
......
src/Gargantext/API/Admin/Settings.hs
View file @ 3e499383
......@@ -14,7 +14,6 @@ TODO-SECURITY: Critical
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Admin.Settings
where
......@@ -31,6 +30,8 @@ import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Types
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.Dispatcher qualified as D
import Gargantext.Core.Config (GargConfig(..), gc_js_job_timeout, gc_js_id_timeout)
import Gargantext.Core.Config.Frontend qualified as Frontend
import Gargantext.Core.Config.Types (SettingsFile(..))
......@@ -207,6 +208,9 @@ 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
{- 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.
-}
......@@ -222,6 +226,8 @@ newEnv logger port settingsFile@(SettingsFile sf) = do
, _env_config = config_env
, _env_mail = _gc_mail_config config_env
, _env_nlp = nlpServerMap $ _gc_nlp_config config_env
, _env_central_exchange = central_exchange
, _env_dispatcher = dispatcher
}
newPool :: ConnectInfo -> IO (Pool Connection)
......
src/Gargantext/API/Admin/Settings/CORS.hs 0 → 100644
View file @ 3e499383
{--| Support in Gargantext for CORS (Cross-origin resource sharing) --}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Gargantext.API.Admin.Settings.CORS where
import Prelude
import Control.Arrow
import Data.Text qualified as T
import Toml
import Control.Lens hiding (iso, (.=))
import Servant.Client.Core
import Data.Maybe (fromMaybe)
newtype CORSOrigin = CORSOrigin { _CORSOrigin :: BaseUrl }
deriving (Show, Eq)
data CORSSettings =
CORSSettings {
_corsAllowedOrigins :: [CORSOrigin]
, _corsAllowedHosts :: [CORSOrigin]
-- | If 'True', we will reuse the origin whitelist
-- as the allowed hosts as well. This allows, for example,
-- to connect from \"demo.gargantext.org\" to \"dev.sub.gargantext.org\"
-- and vice-versa.
, _corsUseOriginsForHosts :: !Bool
} deriving (Show, Eq)
corsOriginCodec :: TomlBiMap CORSOrigin AnyValue
corsOriginCodec = _Orig >>> _Text
where
_Orig :: BiMap e CORSOrigin T.Text
_Orig = iso (T.pack . showBaseUrl . _CORSOrigin)
(\(T.unpack -> u) -> CORSOrigin . fromMaybe (error $ "invalid origin: " <> u) . parseBaseUrl $ u)
corsSettingsCodec :: TomlCodec CORSSettings
corsSettingsCodec = CORSSettings
<$> Toml.arrayOf corsOriginCodec "allowed-origins" .= _corsAllowedOrigins
<*> pure mempty -- FIXME(adn) Currently we don't need to support this field.
<*> Toml.bool "use-origins-for-hosts" .= _corsUseOriginsForHosts
makeLenses ''CORSSettings
src/Gargantext/API/Admin/Settings/MicroServices.hs 0 → 100644
View file @ 3e499383
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Admin.Settings.MicroServices where
import Prelude
import Control.Lens.TH
import Data.Text qualified as T
import Gargantext.Core.Config
import Servant.Client.Core.BaseUrl
import Toml
data MicroServicesSettings =
MicroServicesSettings {
-- | The port where the microservices proxy will be listening on.
_msProxyPort :: !Int
, _msProxyEnabled :: !Bool
} deriving (Show, Eq)
microServicesSettingsCodec :: TomlCodec MicroServicesSettings
microServicesSettingsCodec = MicroServicesSettings
<$> Toml.int "port" .= _msProxyPort
<*> Toml.bool "enabled" .= _msProxyEnabled
mkProxyUrl :: GargConfig -> MicroServicesSettings -> BaseUrl
mkProxyUrl GargConfig{..} MicroServicesSettings{..} =
case parseBaseUrl (T.unpack _gc_url) of
Nothing -> BaseUrl Http "localhost" 80 ""
Just bh -> bh { baseUrlPort = _msProxyPort }
makeLenses ''MicroServicesSettings
src/Gargantext/API/Errors.hs
View file @ 3e499383
......@@ -8,6 +8,7 @@ module Gargantext.API.Errors (
-- * Types
, GargErrorScheme(..)
, renderGargErrorScheme
-- * Conversion functions
, backendErrorToFrontendError
......@@ -48,6 +49,11 @@ data GargErrorScheme
-- https://spec.graphql.org/June2018/#sec-Errors
deriving (Show, Eq)
renderGargErrorScheme :: GargErrorScheme -> T.Text
renderGargErrorScheme = \case
GES_old -> "old"
GES_new -> "new"
-- | Transforms a backend internal error into something that the frontend
-- can consume. This is the only representation we offer to the outside world,
-- as we later encode this into a 'ServerError' in the main server handler.
......@@ -105,12 +111,11 @@ frontendErrorToServerError fe@(FrontendError diag ty _) =
}
internalServerErrorToFrontendError :: ServerError -> FrontendError
internalServerErrorToFrontendError = \case
ServerError{..}
| errHTTPCode == 405
-> mkFrontendErr' (T.pack errReasonPhrase) $ FE_not_allowed (TL.toStrict $ TE.decodeUtf8 $ errBody)
| otherwise
-> mkFrontendErr' (T.pack errReasonPhrase) $ FE_internal_server_error (TL.toStrict $ TE.decodeUtf8 $ errBody)
internalServerErrorToFrontendError ServerError{..}
| errHTTPCode == 405
= mkFrontendErr' (T.pack errReasonPhrase) $ FE_not_allowed (TL.toStrict $ TE.decodeUtf8 $ errBody)
| otherwise
= mkFrontendErr' (T.pack errReasonPhrase) $ FE_internal_server_error (TL.toStrict $ TE.decodeUtf8 $ errBody)
jobErrorToFrontendError :: JobError -> FrontendError
jobErrorToFrontendError = \case
......
src/Gargantext/API/Errors/TH.hs
View file @ 3e499383
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Errors.TH (
deriveHttpStatusCode
, deriveIsFrontendErrorData
......
src/Gargantext/API/Errors/Types.hs
View file @ 3e499383
......@@ -12,7 +12,6 @@ Portability : POSIX
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
......
src/Gargantext/API/GraphQL.hs
View file @ 3e499383
......@@ -25,7 +25,7 @@ import Data.Morpheus ( App, deriveApp )
import Data.Morpheus.Server ( httpPlayground )
import Data.Morpheus.Subscriptions ( Event (..), httpPubApp )
import Data.Morpheus.Types ( GQLRequest, GQLResponse, GQLType, RootResolver(..), Undefined, defaultRootResolver)
import Data.Proxy
-- import Data.Proxy
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
import Gargantext.API.Admin.Orchestrator.Types (JobLog)
import Gargantext.API.Admin.Types (HasSettings)
......@@ -167,8 +167,8 @@ data GraphQLAPIEndpoints mode = GraphQLAPIEndpoints
}
deriving Generic
gqapi :: Proxy (ToServantApi GraphQLAPI)
gqapi = Proxy
-- gqapi :: Proxy (ToServantApi GraphQLAPI)
-- gqapi = Proxy
-- | Implementation of our API.
api
......
src/Gargantext/API/GraphQL/UnPrefix.hs 0 → 100644
View file @ 3e499383
{-|
Module : Gargantext.API.GraphQL.UnPrefix
Description : Un-prefix for GraphQL API
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -Wno-deprecations #-} -- FIXME(adn) GraphQL will need updating.
module Gargantext.API.GraphQL.UnPrefix where
import Data.Morpheus.Types (GQLTypeOptions, fieldLabelModifier)
import Data.Text qualified as T
import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
import Gargantext.Prelude
unPrefix :: T.Text -> GQLTypeOptions -> GQLTypeOptions
unPrefix prefix options = options { fieldLabelModifier = nflm }
where
nflm label = unCapitalize $ dropPrefix (T.unpack prefix) $ ( fieldLabelModifier options ) label
src/Gargantext/API/GraphQL/Utils.hs
View file @ 3e499383
......@@ -13,21 +13,13 @@ Portability : POSIX
module Gargantext.API.GraphQL.Utils where
import Control.Lens (view)
import Data.Morpheus.Types (GQLTypeOptions, fieldLabelModifier)
import Data.Text qualified as T
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser (..), auth_node_id)
import Gargantext.API.Admin.Types (jwtSettings, HasSettings (settings))
import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Prelude (Cmd')
import Gargantext.Prelude
import Servant.Auth.Server (verifyJWT, JWTSettings)
unPrefix :: T.Text -> GQLTypeOptions -> GQLTypeOptions
unPrefix prefix options = options { fieldLabelModifier = nflm }
where
nflm label = unCapitalize $ dropPrefix (T.unpack prefix) $ ( fieldLabelModifier options ) label
data AuthStatus = Valid | Invalid
authUser :: (HasSettings env) => NodeId -> Text -> Cmd' env err AuthStatus
......
src/Gargantext/API/Middleware.hs
View file @ 3e499383
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-| Edit 'sensitiveKeywords' to extend the list of redacted fields. -}
......
src/Gargantext/API/Node/Corpus/New.hs
View file @ 3e499383
......@@ -60,7 +60,6 @@ import Gargantext.Prelude
import Gargantext.Core.Config (gc_max_docs_parsers)
import Gargantext.System.Logging ( logLocM, LogLevel(..) )
import Gargantext.Utils.Jobs.Monad (JobHandle, MonadJobStatus(..))
import Test.QuickCheck.Arbitrary (Arbitrary(..))
------------------------------------------------------------------------
{-
......@@ -120,8 +119,6 @@ api uid (Query q _ as) = do
-- TODO use this route for Client implementation
data ApiInfo = ApiInfo { api_info :: [API.ExternalAPIs]}
deriving (Generic)
instance Arbitrary ApiInfo where
arbitrary = ApiInfo <$> arbitrary
deriveJSON (unPrefix "") 'ApiInfo
......
src/Gargantext/API/Node/New.hs
View file @ 3e499383
......@@ -28,6 +28,7 @@ import Gargantext.API.Errors.Types
import Gargantext.API.Node.New.Types
import Gargantext.API.Prelude
import Gargantext.API.Routes.Named.Node qualified as Named
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CE
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Node
import Gargantext.Database.Admin.Types.Node
......@@ -39,7 +40,7 @@ import Servant.Server.Generic (AsServerT)
import Gargantext.API.Admin.Types (HasSettings)
------------------------------------------------------------------------
postNode :: (HasNodeError err, HasSettings env)
postNode :: (HasNodeError err, HasSettings env, CE.HasCentralExchangeNotification env)
=> AuthenticatedUser
-- ^ The logged-in user
-> NodeId
......@@ -47,7 +48,12 @@ postNode :: (HasNodeError err, HasSettings env)
-> DBCmd' env err [NodeId]
postNode authenticatedUser pId (PostNode nodeName nt) = do
let userId = authenticatedUser ^. auth_user_id
mkNodeWithParent nt (Just pId) userId nodeName
nodeIds <- mkNodeWithParent nt (Just pId) userId nodeName
-- mapM_ (CE.ce_notify . CE.UpdateTreeFirstLevel) nodeIds
CE.ce_notify $ CE.UpdateTreeFirstLevel pId
return nodeIds
postNodeAsyncAPI
:: AuthenticatedUser
......@@ -59,7 +65,7 @@ postNodeAsyncAPI authenticatedUser nId = Named.PostNodeAsyncAPI $ AsyncJobs $
serveJobsAPI NewNodeJob $ \jHandle p -> postNodeAsync authenticatedUser nId p jHandle
------------------------------------------------------------------------
postNodeAsync :: (FlowCmdM env err m, MonadJobStatus m, HasSettings env)
postNodeAsync :: (FlowCmdM env err m, MonadJobStatus m, HasSettings env, CE.HasCentralExchangeNotification env)
=> AuthenticatedUser
-- ^ The logged in user
-> NodeId
......@@ -76,6 +82,9 @@ postNodeAsync authenticatedUser nId (PostNode nodeName tn) jobHandle = do
markProgress 1 jobHandle
let userId = authenticatedUser ^. auth_user_id
_ <- mkNodeWithParent tn (Just nId) userId nodeName
_nodeIds <- mkNodeWithParent tn (Just nId) userId nodeName
-- mapM_ (CE.ce_notify . CE.UpdateTreeFirstLevel) nodeIds
CE.ce_notify $ CE.UpdateTreeFirstLevel nId
markComplete jobHandle
src/Gargantext/API/Node/Share.hs
View file @ 3e499383
......@@ -20,6 +20,7 @@ import Data.Text qualified as Text
import Gargantext.API.Node.Share.Types
import Gargantext.API.Prelude
import Gargantext.API.Routes.Named.Share qualified as Named
import Gargantext.Core.AsyncUpdates.CentralExchange.Types (HasCentralExchangeNotification)
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.Types.Individu (User(..), arbitraryUsername)
import Gargantext.Database.Action.Share (ShareNodeWith(..))
......@@ -38,7 +39,11 @@ import Gargantext.API.Admin.Types (HasSettings)
-- TODO permission
-- TODO refactor userId which is used twice
-- TODO change return type for better warning/info/success/error handling on the front
api :: (HasNodeError err, HasNLPServer env, CmdRandom env err m, HasSettings env)
api :: ( HasNodeError err
, HasNLPServer env
, CmdRandom env err m
, HasSettings env
, HasCentralExchangeNotification env )
=> User
-> NodeId
-> ShareNodeParams
......
src/Gargantext/API/Node/Types.hs
View file @ 3e499383
......@@ -29,7 +29,6 @@ import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
import Gargantext.Database.GargDB qualified as GargDB
import Gargantext.Prelude
import Servant.Job.Utils (jsonOptions)
import Test.QuickCheck
import Web.FormUrlEncoded (FromForm, ToForm)
-------------------------------------------------------
......@@ -104,25 +103,12 @@ instance ToJSON WithQuery where
instance ToSchema WithQuery where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wq_")
instance Arbitrary WithQuery where
arbitrary = WithQuery <$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
------------------------------------------------------------------------
data RenameNode = RenameNode { r_name :: Text }
deriving (Generic)
$(deriveJSON (unPrefix "r_" ) ''RenameNode )
instance ToSchema RenameNode
instance Arbitrary RenameNode where
arbitrary = elements [RenameNode "test"]
data NodesToScore = NodesToScore { nts_nodesId :: [NodeId]
, nts_score :: Int
......
src/Gargantext/API/Prelude.hs
View file @ 3e499383
......@@ -26,6 +26,7 @@ import Gargantext.API.Admin.Auth.Types (AuthenticationError)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Admin.Types
import Gargantext.API.Errors.Class
import Gargantext.Core.AsyncUpdates.CentralExchange.Types (HasCentralExchangeNotification)
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.NodeStory
......@@ -53,6 +54,7 @@ type EnvC env =
, HasNodeStoryEnv env
, HasMail env
, HasNLPServer env
, HasCentralExchangeNotification env
)
type ErrC err =
......
src/Gargantext/API/Routes.hs
View file @ 3e499383
......@@ -12,9 +12,9 @@ Portability : POSIX
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance HasSwagger (WithCustomErrorScheme GargAPI)
......
src/Gargantext/API/Routes/Named.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
module Gargantext.API.Routes.Named (
......@@ -28,6 +27,7 @@ import Gargantext.API.GraphQL
import Gargantext.API.Routes.Named.Private
import Gargantext.API.Routes.Named.Public
import Gargantext.API.Routes.Types
import Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket qualified as Dispatcher
import Servant.API ((:>), (:-), JSON, ReqBody, Post, Get, QueryParam)
import Servant.API.Description (Summary)
import Servant.API.NamedRoutes
......@@ -42,7 +42,9 @@ newtype API mode = API
data NamedAPI mode = NamedAPI
{ swaggerAPI :: mode :- SwaggerSchemaUI "swagger-ui" "swagger.json"
, backendAPI :: mode :- NamedRoutes BackEndAPI
, graphqlAPI :: mode :- NamedRoutes GraphQLAPI -- FIXME(adn) convert to named!
, graphqlAPI :: mode :- NamedRoutes GraphQLAPI
, wsAPI :: mode :- NamedRoutes Dispatcher.WSAPI
-- NOTE: FrontEndAPI is Raw and is a catch-all so needs to be at the end!
, frontendAPI :: mode :- FrontEndAPI
} deriving Generic
......
src/Gargantext/API/Routes/Named/Annuaire.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.Annuaire (
-- * Routes types
AddAnnuaireWithForm(..)
......
src/Gargantext/API/Routes/Named/Contact.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.Contact (
-- * Routes types
ContactAPI(..)
......
src/Gargantext/API/Routes/Named/Context.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.Context (
-- * Routes types
......
src/Gargantext/API/Routes/Named/Corpus.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.Corpus (
-- * Routes types
CorpusExportAPI(..)
......
src/Gargantext/API/Routes/Named/Count.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.Count (
-- * Routes types
CountAPI(..)
......
src/Gargantext/API/Routes/Named/Document.hs
View file @ 3e499383
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.API.Routes.Named.Document (
-- * Routes types
DocumentsFromWriteNodesAPI(..)
......
src/Gargantext/API/Routes/Named/EKG.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.EKG (
-- * Routes types
EkgAPI(..)
......
src/Gargantext/API/Routes/Named/File.hs
View file @ 3e499383
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.API.Routes.Named.File (
-- * Routes types
FileAPI(..)
......
src/Gargantext/API/Routes/Named/FrameCalc.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.FrameCalc (
-- * Routes types
......
src/Gargantext/API/Routes/Named/List.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.List (
-- * Routes types
GETAPI(..)
......
src/Gargantext/API/Routes/Named/Metrics.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.Metrics (
-- * Routes types
......
src/Gargantext/API/Routes/Named/Node.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.Node (
-- * Routes types
NodeAPI(..)
......
src/Gargantext/API/Routes/Named/Private.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
......@@ -87,7 +86,7 @@ data GargPrivateAPI' mode = GargPrivateAPI'
:> Capture "tree_id" NodeId
:> NamedRoutes TreeFlatAPI
, membersAPI :: mode :- "members" :> Summary "Team node members" :> NamedRoutes MembersAPI
, addWithFormEp :: mode :- NamedRoutes AddWithForm
, addWithFormAPI :: mode :- NamedRoutes AddWithForm
, addWithQueryEp :: mode :- NamedRoutes AddWithQuery
, listGetAPI :: mode :- NamedRoutes List.GETAPI
, listJsonAPI :: mode :- NamedRoutes List.JSONAPI
......
src/Gargantext/API/Routes/Named/Public.hs
View file @ 3e499383
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.API.Routes.Named.Public (
-- * Routes types
GargPublicAPI(..)
......
src/Gargantext/API/Routes/Named/Search.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.Search (
-- * Routes types
SearchAPI(..)
......
src/Gargantext/API/Routes/Named/Share.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
module Gargantext.API.Routes.Named.Share (
......
src/Gargantext/API/Routes/Named/Table.hs
View file @ 3e499383
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
......
src/Gargantext/API/Routes/Named/Tree.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.Tree (
-- * Routes types
......
src/Gargantext/API/Routes/Named/Viz.hs
View file @ 3e499383
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
module Gargantext.API.Routes.Named.Viz (
-- * Routes types
......@@ -53,11 +52,12 @@ newtype PostPhylo mode = PostPhylo
-- | There is no Delete specific API for Graph since it can be deleted
-- as simple Node.
data GraphAPI mode = GraphAPI
{ getGraphEp :: mode :- Get '[JSON] HyperdataGraphAPI
, getGraphAsyncEp :: mode :- "async" :> NamedRoutes GraphAsyncAPI
, cloneGraphEp :: mode :- "clone" :> ReqBody '[JSON] HyperdataGraphAPI :> Post '[JSON] NodeId
, gexfEp :: mode :- "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
, graphVersionsAPI :: mode :- "versions" :> NamedRoutes GraphVersionsAPI
{ getGraphEp :: mode :- Get '[JSON] HyperdataGraphAPI
, getGraphAsyncEp :: mode :- "async" :> NamedRoutes GraphAsyncAPI
, cloneGraphEp :: mode :- "clone" :> ReqBody '[JSON] HyperdataGraphAPI :> Post '[JSON] NodeId
, gexfEp :: mode :- "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
, graphVersionsAPI :: mode :- "versions" :> NamedRoutes GraphVersionsAPI
, updateGraphLegendEp :: mode :- "legend" :> ReqBody '[JSON] GraphLegendAPI :> Post '[JSON] NodeId
} deriving Generic
......
src/Gargantext/API/Routes/Types.hs
View file @ 3e499383
......@@ -5,6 +5,7 @@ module Gargantext.API.Routes.Types where
import Control.Lens
import Data.ByteString (ByteString)
import Data.CaseInsensitive qualified as CI
import Data.List qualified as L
import Data.Proxy
import Data.Set qualified as Set
......@@ -12,16 +13,21 @@ import Gargantext.API.Errors
import Network.Wai hiding (responseHeaders)
import Prelude
import Servant.API.Routes
import Servant.API.Routes.Internal.Response (unResponses)
import Servant.API.Routes.Route
import Servant.Client hiding (responseHeaders)
import Servant.Client.Core.Request (addHeader)
import Servant.Ekg
import Servant.Server
import Servant.Server.Internal.Delayed
import Servant.Server.Internal.DelayedIO
import Servant.API.Routes.Route
import Servant.API.Routes.Internal.Response (unResponses)
import Network.HTTP.Types (HeaderName)
data WithCustomErrorScheme a
xGargErrorScheme :: HeaderName
xGargErrorScheme = CI.mk "X-Garg-Error-Scheme"
instance (HasServer subApi ctx) => HasServer (WithCustomErrorScheme subApi) ctx where
type ServerT (WithCustomErrorScheme subApi) m = GargErrorScheme -> ServerT subApi m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy subApi) pc nt . s
......@@ -30,7 +36,7 @@ instance (HasServer subApi ctx) => HasServer (WithCustomErrorScheme subApi) ctx
getErrorScheme :: DelayedIO GargErrorScheme
getErrorScheme = withRequest $ \rq -> do
let hdrs = requestHeaders rq
in case L.lookup "X-Garg-Error-Scheme" hdrs of
in case L.lookup xGargErrorScheme hdrs of
Nothing -> pure GES_old
Just "new" -> pure GES_new
Just _ -> pure GES_old
......@@ -41,7 +47,9 @@ instance HasEndpoint sub => HasEndpoint (WithCustomErrorScheme sub) where
instance HasClient m sub => HasClient m (WithCustomErrorScheme sub) where
type Client m (WithCustomErrorScheme sub) = GargErrorScheme -> Client m sub
clientWithRoute m _ req _mgr = clientWithRoute m (Proxy :: Proxy sub) req
clientWithRoute m _ req0 _mgr =
let req = addHeader xGargErrorScheme (renderGargErrorScheme $ GES_new) req0
in clientWithRoute m (Proxy :: Proxy sub) req
hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt . cl
......@@ -49,5 +57,5 @@ instance (HasRoutes subApi) => HasRoutes (WithCustomErrorScheme subApi) where
getRoutes =
let apiRoutes = getRoutes @subApi
errHeader = mkHeaderRep @"X-Garg-Error-Scheme" @ByteString
addHeader rt = rt & routeResponse . unResponses . traversed . responseHeaders %~ Set.insert errHeader
in addHeader <$> apiRoutes
addHeader' rt = rt & routeResponse . unResponses . traversed . responseHeaders %~ Set.insert errHeader
in addHeader' <$> apiRoutes
src/Gargantext/API/Server/Named.hs
View file @ 3e499383
......@@ -22,6 +22,7 @@ import Gargantext.API.Server.Named.Public (serverPublicGargAPI)
import Gargantext.API.Routes.Named
import Gargantext.API.Swagger (swaggerDoc)
import Gargantext.API.ThrowAll (serverPrivateGargAPI)
import Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket qualified as Dispatcher
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Prelude hiding (Handler, catch)
import Gargantext.Core.Config (gc_url_backend_api)
......@@ -60,6 +61,11 @@ server env =
(Proxy :: Proxy AuthContext)
(transformJSONGQL errScheme)
GraphQL.api
, wsAPI = hoistServer
(Proxy :: Proxy (NamedRoutes Dispatcher.WSAPI))
-- (Proxy :: Proxy AuthContext)
(transformJSON errScheme)
Dispatcher.wsServer
, frontendAPI = frontEndServer
}
where
......
src/Gargantext/API/Server/Named/Private.hs
View file @ 3e499383
......@@ -58,7 +58,7 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
, treeAPI = Tree.treeAPI authenticatedUser
, treeFlatAPI = Tree.treeFlatAPI authenticatedUser
, membersAPI = members
, addWithFormEp = addCorpusWithForm (RootId userNodeId)
, addWithFormAPI = addCorpusWithForm (RootId userNodeId)
, addWithQueryEp = addCorpusWithQuery (RootId userNodeId)
, listGetAPI = List.getAPI
, listJsonAPI = List.jsonAPI
......
src/Gargantext/API/Server/Named/Viz.hs
View file @ 3e499383
......@@ -19,11 +19,12 @@ import Servant.Server.Generic (AsServerT)
graphAPI :: AuthenticatedUser -> UserId -> NodeId -> Named.GraphAPI (AsServerT (GargM Env BackendInternalError))
graphAPI authenticatedUser userId n = withNamedAccess authenticatedUser (PathNode n) $ Named.GraphAPI
{ getGraphEp = getGraph n
, getGraphAsyncEp = graphAsync n
, cloneGraphEp = graphClone userId n
, gexfEp = getGraphGexf n
, graphVersionsAPI = graphVersionsAPI userId n
{ getGraphEp = getGraph n
, getGraphAsyncEp = graphAsync n
, cloneGraphEp = graphClone userId n
, gexfEp = getGraphGexf n
, graphVersionsAPI = graphVersionsAPI userId n
, updateGraphLegendEp = updateGraphLegend n
}
......
src/Gargantext/Core/AsyncUpdates.hs 0 → 100644
View file @ 3e499383
{-|
Module : Gargantext.Core.AsyncUpdates
Description : Asynchronous updates to the frontend
Copyright : (c) CNRS, 2024-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -Wno-deprecations #-} -- FIXME(cgenie) undefined remains in code
module Gargantext.Core.AsyncUpdates
where
import Gargantext.Core.Types (NodeId, UserId)
import Protolude
{-
Please note that we have 2 different notification mechanisms:
- external (i.e. WebSocket or SSE connection to the frontend)
- internal (e.g. job workers would like to report either progress or
that some node changed in the tree)
I imagine the workflow as follows (this is a mix of internal and
external communication):
- somewhere in the code (or in the async job worker) we decide to send
an update message to all interested users
- such an action (UserAction) can be associated with the triggering
user (but doesn't have to be)
- we compute interested users for given notification
- we broadcast (using our broker) these notifications to all
interested users
- the broadcast message is either simple (meaning: hey, we have new
data, if you want you can send an update request) or we could send
the changed data already
On the client side it looks more or less like this (external
communication):
- specific components decide to subscribe to specific
UserNotifications: task component is interested in running tasks (for
given node id), tree component is interested in the tree and its
first-level children (same for the children components)
- the components react to events accordingly (usually by pulling in
new data)
Thus, for example, the triple (user_id, node_id, "update_tree")
defines a "update tree for given user and given node" subscription to
this event, both for server and client. This triple is then the
"touching point" between client and server. Through that point, update
messages are sent from server.
Subscription to topics is important IMHO because it allows to target
clients directly rather than broadcasting messages to everyone. This
reduces latency and is more secure. At the same time it is a bit more
complicated because we need to agree on the topic schema both on
server and client.
As for internal communication, we don't need topics: we always want to
get all notifications and process them accordingly (send messages to
connected users, ignore any messages that would be sent to
non-connected users).
-}
-------------------------
-- EXTERNAL COMMUNICATION
-------------------------
-- | Various topics that users can subscribe to
data Topic =
-- | Update given Servant Job (we currently send a request every
-- | second to get job status).
-- UpdateJob JobID
-- | Given parent node id, trigger update of the node and its
-- children (e.g. list is automatically created in a corpus)
UpdateTree NodeId
deriving (Eq, Show)
-- TODO: I'm not sure if UserAction/UserSource is needed. I initially
-- created that to mark who initiated the action, but I think we don't
-- need it.
--
-- Suppose we send an 'UpdateTree node_id' message: from the DB we can
-- infer all users that are associated with that node (I do keep in
-- mind that we can share nodes to other users).
data UserSource =
USUser UserId
| USSystem
deriving (Eq, Show)
-- | Action possibly associated with user who triggered it (there can
-- be system actions as well)
data UserAction =
UserAction UserSource Topic
deriving (Eq, Show)
-- | Represents a notification that goes to a given user. This is
-- directly sent via WebSockets.
--
-- NOTE: Do we need public notifications? I.e. sent out to non-logged
-- in users?
data UserNotification =
UserNotification UserId UserAction
deriving (Eq, Show)
-- | What we want now is, given a UserAction action, generate all
-- interested users to which the notification will be sent.
-- This function lives in a monad because we have to fetch users
-- from DB.
notificationsForUserAction :: UserAction -> m [ UserNotification ]
notificationsForUserAction = undefined
-- | A connected user can be either associated with his UserId or
-- don't have it, since he's not logged in (for public messages).
data ConnectedUser =
CUUser UserId
| CUPublic
deriving (Eq, Show)
-- | Stores connection type associated with given user, subscribed to
-- | a given topic.
--
-- We probably should set conn = Servant.API.WebSocket.Connection
data Subscription conn =
Subscription ConnectedUser conn Topic
-- | Given a UserNotification and all subscriptions, send it to all
-- matching ones. Possibly we could make this function as part of a
-- typeclass so that we can decide how to send the notification
-- based on whether we choose pure WebSockets, NATS or something
-- else.
sendNotification :: UserNotification -> [ Subscription conn ] -> m ()
sendNotification = undefined
src/Gargantext/Core/AsyncUpdates/CentralExchange.hs 0 → 100644
View file @ 3e499383
{-|
Module : Gargantext.Core.AsyncUpdates.CentralExchange
Description : Central exchange (asynchronous notifications)
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.CentralExchange where
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 Gargantext.Core.AsyncUpdates.CentralExchange.Types
import Gargantext.Core.AsyncUpdates.Constants (ceBind, ceConnect, dispatcherConnect)
import Gargantext.Prelude
import Gargantext.System.Logging (LogLevel(DEBUG), withLogger, logMsg)
import Nanomsg (Pull(..), Push(..), bind, connect, recvMalloc, send, withSocket)
{-
Central exchange is a service, which gathers messages from various
places and informs the Dispatcher (which will then inform users about
various events).
The primary goal is to be able to read as many messages as possible
and then send them to the Dispatcher. Although nanomsg does some
message buffering, we don't want these messages to pile up, especially
with many users having updates.
-}
gServer :: IO ()
gServer = do
withSocket Pull $ \s -> do
withSocket Push $ \s_dispatcher -> do
_ <- bind s ceBind
_ <- connect s_dispatcher dispatcherConnect
tChan <- TChan.newTChanIO
-- | We have 2 threads: one that listens for nanomsg messages
-- | and puts them on the 'tChan' and the second one that reads
-- | the 'tChan' and calls Dispatcher accordingly. This is to
-- | make reading nanomsg as fast as possible.
void $ Async.concurrently (worker s_dispatcher tChan) $ do
forever $ do
-- putText "[central_exchange] receiving"
r <- recvMalloc s 1024
-- C.putStrLn $ "[central_exchange] " <> r
atomically $ TChan.writeTChan tChan r
where
worker s_dispatcher tChan = do
withLogger () $ \ioLogger -> do
forever $ do
r <- atomically $ TChan.readTChan tChan
case Aeson.decode (BSL.fromStrict r) of
Just _ujp@(UpdateJobProgress _s) -> do
-- logMsg ioLogger DEBUG $ "[central_exchange] " <> show ujp
-- 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
-- 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)
-- NOTE: If we're flooded with messages, and send is
-- slow, we might be spawning many threads...
-- NOTE: Currently we just forward the message that we
-- got. So in theory central exchange isn't needed (we
-- could ping dispatcher directly). However, I think
-- it's better to have this as a separate
-- component. Currently I built this inside
-- gargantext-server but maybe it can be a separate
-- process, independent of the server.
-- send the same message that we received
send s_dispatcher r
_ -> logMsg ioLogger DEBUG $ "[central_exchange] unknown message"
notify :: CEMessage -> IO ()
notify ceMessage = do
Async.withAsync (pure ()) $ \_ -> do
withSocket Push $ \s -> do
_ <- connect s ceConnect
let str = Aeson.encode ceMessage
send s $ BSL.toStrict str
src/Gargantext/Core/AsyncUpdates/CentralExchange/Types.hs 0 → 100644
View file @ 3e499383
{-|
Module : Gargantext.Core.AsyncUpdates.CentralExchange.Types
Description : Types for asynchronous notifications (central exchange)
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.CentralExchange.Types where
import Codec.Binary.UTF8.String qualified as CBUTF8
import Data.Aeson ((.:), (.=), object, withObject)
import Data.Aeson qualified as Aeson
import Data.Aeson.Types (prependFailure, typeMismatch)
import Data.ByteString.Lazy qualified as BSL
import Gargantext.API.Admin.Orchestrator.Types (JobLog)
import Gargantext.Core.Types (NodeId)
import Gargantext.Prelude
import Prelude qualified
import Servant.Job.Core (Safety(Safe))
import Servant.Job.Types (JobStatus)
{-
Central exchange is a service, which gathers messages from various
places and informs the Dispatcher (which will then inform users about
various events).
-}
-- INTERNAL MESSAGES
data CEMessage =
UpdateJobProgress (JobStatus 'Safe JobLog)
| UpdateTreeFirstLevel NodeId
instance Prelude.Show CEMessage where
show (UpdateJobProgress js) = "UpdateJobProgress " <> (CBUTF8.decode $ BSL.unpack $ Aeson.encode js)
show (UpdateTreeFirstLevel nodeId) = "UpdateTreeFirstLevel " <> show nodeId
instance FromJSON CEMessage where
parseJSON = withObject "CEMessage" $ \o -> do
type_ <- o .: "type"
case type_ of
"update_job_progress" -> do
js <- o .: "js"
pure $ UpdateJobProgress js
"update_tree_first_level" -> do
node_id <- o .: "node_id"
pure $ UpdateTreeFirstLevel node_id
s -> prependFailure "parsing type failed, " (typeMismatch "type" s)
instance ToJSON CEMessage where
toJSON (UpdateJobProgress js) = object [
"type" .= toJSON ("update_job_progress" :: Text)
, "js" .= toJSON js
]
toJSON (UpdateTreeFirstLevel node_id) = object [
"type" .= toJSON ("update_tree_first_level" :: Text)
, "node_id" .= toJSON node_id
]
class HasCentralExchangeNotification env where
ce_notify :: (MonadReader env m, MonadBase IO m) => CEMessage -> m ()
src/Gargantext/Core/AsyncUpdates/Constants.hs 0 → 100644
View file @ 3e499383
{-|
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 0 → 100644
View file @ 3e499383
{-|
Module : Gargantext.Core.AsyncUpdates.Dispatcher
Description : Dispatcher (handles websocket connections, accepts message from central exchange)
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
-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.Core.AsyncUpdates.Dispatcher where
import Control.Concurrent.Async qualified as Async
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 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.Prelude
import Gargantext.System.Logging (LogLevel(DEBUG), withLogger, logMsg)
import Nanomsg (Pull(..), bind, recvMalloc, withSocket)
import Network.WebSockets qualified as WS
import Servant.Job.Types (JobStatus(_job_id))
import StmContainers.Set qualified as SSet
{-
Dispatcher is a service, which provides couple of functionalities:
- handles WebSocket connections and manages them
- accepts messages from central exchange
- dispatches these messages to connected users
-}
dispatcher :: IO Dispatcher
dispatcher = do
subscriptions <- SSet.newIO
-- let server = wsServer authSettings subscriptions
d_ce_listener <- forkIO (dispatcherListener subscriptions)
pure $ Dispatcher { d_subscriptions = subscriptions
-- , d_ws_server = server
, d_ce_listener = d_ce_listener }
-- | 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
withSocket Pull $ \s -> do
_ <- bind s AUConstants.dispatcherBind
tChan <- TChan.newTChanIO
throttleTChan <- TChan.newTChanIO
-- NOTE I'm not sure that we need more than 1 worker here, but in
-- theory, the worker can perform things like user authentication,
-- DB queries etc so it can be slow sometimes.
Async.withAsync (throttle 500_000 throttleTChan sendDataMessageThrottled) $ \_ -> do
void $ Async.concurrently (Async.replicateConcurrently 5 $ worker tChan throttleTChan) $ do
forever $ do
-- putText "[dispatcher_listener] receiving"
r <- recvMalloc s 1024
-- C.putStrLn $ "[dispatcher_listener] " <> r
atomically $ TChan.writeTChan tChan r
where
worker tChan throttleTChan = do
-- tId <- myThreadId
forever $ do
r <- atomically $ TChan.readTChan tChan
-- putText $ "[" <> show tId <> "] received a message: " <> decodeUtf8 r
case Aeson.decode (BSL.fromStrict r) of
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
filteredSubs <- atomically $ do
let subs' = UnfoldlM.filter (pure . ceMessageSubPred ceMessage) $ SSet.unfoldlM subscriptions
UnfoldlM.foldlM' (\acc sub -> pure $ acc <> [sub]) [] subs'
-- NOTE This isn't safe: we atomically fetch subscriptions,
-- then send notifications one by one. In the meantime, a
-- subscription could end or new ones could appear (but is
-- this really a problem? I new subscription comes up, then
-- probably they already fetch new tree anyways, and if old
-- one drops in the meantime, it won't listen to what we
-- send...)
-- let filteredSubs = filterCEMessageSubs ceMessage subs
mapM_ (sendNotification throttleTChan ceMessage) filteredSubs
-- | When processing tasks such as Flow, we can generate quite a few
-- notifications in a short time. We want to limit this with throttle
-- tchan.
sendNotification :: TChan.TChan ((ByteString, Topic), (WS.Connection, WS.DataMessage))
-> CETypes.CEMessage
-> Subscription
-> IO ()
sendNotification throttleTChan ceMessage sub = do
let ws = s_ws_key_connection sub
let topic = s_topic sub
notification <-
case ceMessage of
CETypes.UpdateJobProgress jobStatus -> do
pure $ Notification topic (MJobProgress jobStatus)
CETypes.UpdateTreeFirstLevel _nodeId -> pure $ Notification topic MEmpty
let id' = (wsKey ws, topic)
atomically $ TChan.writeTChan throttleTChan (id', (wsConn ws, WS.Text (Aeson.encode notification) Nothing))
sendDataMessageThrottled :: (WS.Connection, WS.DataMessage) -> IO ()
sendDataMessageThrottled (conn, msg) =
WS.sendDataMessage conn msg
-- Custom filtering of list of Subscriptions based on
-- CETypes.CEMessage.
-- For example, we can add CEMessage.Broadcast to propagate a
-- notification to all connections.
filterCEMessageSubs :: CETypes.CEMessage -> [Subscription] -> [Subscription]
filterCEMessageSubs ceMessage subscriptions = filter (ceMessageSubPred ceMessage) subscriptions
ceMessageSubPred :: CETypes.CEMessage -> Subscription -> Bool
ceMessageSubPred (CETypes.UpdateJobProgress js) (Subscription { s_topic }) =
s_topic == (UpdateJobProgress $ _job_id js)
ceMessageSubPred (CETypes.UpdateTreeFirstLevel node_id) (Subscription { s_topic }) =
s_topic == UpdateTree node_id
src/Gargantext/Core/AsyncUpdates/Dispatcher/Subscriptions.hs 0 → 100644
View file @ 3e499383
{-|
Module : Gargantext.Core.AsyncUpdates.Dispatcher.Subscriptions
Description : Dispatcher (manage websocket subscriptions)
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.Dispatcher.Subscriptions where
import DeferredFolds.UnfoldlM qualified as UnfoldlM
import Gargantext.Core.AsyncUpdates.Dispatcher.Types
import Gargantext.Prelude
import StmContainers.Set as SSet
-- | TODO Allow only 1 topic subscription per connection. It doesn't
-- | make sense to send multiple notifications of the same type to the
-- | same connection.
insertSubscription :: SSet.Set Subscription -> Subscription -> IO ()
insertSubscription subscriptions sub = do
atomically $ SSet.insert sub subscriptions
-- s <- readTVar subscriptions
-- let ss = nubBy eqSub $ s <> [sub]
-- writeTVar subscriptions ss
-- -- pure ss
-- pure ()
removeSubscription :: SSet.Set Subscription -> Subscription -> IO ()
removeSubscription subscriptions sub = do
atomically $ SSet.delete sub subscriptions
-- s <- readTVar subscriptions
-- let ss = filter (\sub' -> not $ sub `eqSub` sub') s
-- writeTVar subscriptions ss
-- pure ss
removeSubscriptionsForWSKey :: SSet.Set Subscription -> WSKeyConnection -> IO ()
removeSubscriptionsForWSKey subscriptions ws = do
atomically $ do
let toDelete = UnfoldlM.filter (\sub -> return $ subKey sub == wsKey ws) $ SSet.unfoldlM subscriptions
UnfoldlM.mapM_ (\sub -> SSet.delete sub subscriptions) toDelete
-- atomically $ do
-- s <- readTVar subscriptions
-- let ss = filter (\sub -> subKey sub /= wsKey ws) s
-- writeTVar subscriptions ss
-- pure ss
src/Gargantext/Core/AsyncUpdates/Dispatcher/Types.hs 0 → 100644
View file @ 3e499383
{-|
Module : Gargantext.Core.AsyncUpdates.Dispatcher.Types
Description : Dispatcher (handles websocket connections, accepts message from central exchange)
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
-}
{-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-unused-imports #-}
module Gargantext.Core.AsyncUpdates.Dispatcher.Types where
import Codec.Binary.UTF8.String qualified as CBUTF8
import Control.Concurrent.Async qualified as Async
import Control.Lens (Getter, view)
import Data.Aeson ((.:), (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types (prependFailure, typeMismatch)
import Data.ByteString.Char8 qualified as C
import Data.ByteString.Lazy qualified as BSL
import Data.List (nubBy)
import DeferredFolds.UnfoldlM qualified as UnfoldlM
import Data.UUID.V4 as UUID
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(_auth_user_id))
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)
import Nanomsg
import Network.WebSockets qualified as WS
import Prelude qualified
import Protolude.Base (Show(showsPrec))
import Servant
-- import Servant.API.NamedRoutes ((:-))
import Servant.API.WebSocket qualified as WS
import Servant.Auth.Server (verifyJWT)
import Servant.Job.Core (Safety(Safe))
import Servant.Job.Types (JobID, JobStatus(_job_id))
import Servant.Server.Generic (AsServer, AsServerT)
import StmContainers.Set as SSet
-- | A topic is sent, when a client wants to subscribe to specific
-- | types of notifications
data Topic =
-- | Update given Servant Job (we currently send a request every
-- | second to get job status).
UpdateJobProgress (JobID 'Safe)
-- | Given parent node id, trigger update of the node and its
-- children (e.g. list is automatically created in a corpus)
| UpdateTree NodeId
deriving (Eq, Ord)
instance Prelude.Show Topic where
show (UpdateJobProgress jId) = "UpdateJobProgress " <> (CBUTF8.decode $ BSL.unpack $ Aeson.encode jId)
show (UpdateTree nodeId) = "UpdateTree " <> show nodeId
instance Hashable Topic where
hashWithSalt salt (UpdateJobProgress jId) = hashWithSalt salt ("update-job-progress" :: Text, Aeson.encode jId)
hashWithSalt salt (UpdateTree nodeId) = hashWithSalt salt ("update-tree" :: Text, nodeId)
instance FromJSON Topic where
parseJSON = Aeson.withObject "Topic" $ \o -> do
type_ <- o .: "type"
case type_ of
"update_job_progress" -> do
jId <- o .: "j_id"
pure $ UpdateJobProgress jId
"update_tree" -> do
node_id <- o .: "node_id"
pure $ UpdateTree node_id
s -> prependFailure "parsing type failed, " (typeMismatch "type" s)
instance ToJSON Topic where
toJSON (UpdateJobProgress jId) = Aeson.object [
"type" .= toJSON ("update_job_progress" :: Text)
, "j_id" .= toJSON jId
]
toJSON (UpdateTree node_id) = Aeson.object [
"type" .= toJSON ("update_tree" :: Text)
, "node_id" .= toJSON node_id
]
-- | A message to be sent inside a Notification
data Message =
MJobProgress (JobStatus 'Safe JobLog)
| MEmpty
-- | For tests
instance Eq Message where
(==) (MJobProgress js1) (MJobProgress js2) = _job_id js1 == _job_id js2
(==) MEmpty MEmpty = True
(==) _ _ = False
instance Prelude.Show Message where
show (MJobProgress jobStatus) = "MJobProgress " <> (CBUTF8.decode $ BSL.unpack $ Aeson.encode jobStatus)
show MEmpty = "MEmpty"
instance ToJSON Message where
toJSON (MJobProgress jobStatus) = Aeson.object [
"type" .= toJSON ("MJobProgress" :: Text)
, "job_status" .= toJSON jobStatus
]
toJSON MEmpty = Aeson.object [
"type" .= toJSON ("MEmpty" :: Text)
]
instance FromJSON Message where
parseJSON = Aeson.withObject "Message" $ \o -> do
type_ <- o .: "type"
case type_ of
"MJobProgress" -> do
job_status <- o .: "job_status"
pure $ MJobProgress job_status
"MEmpty" -> pure MEmpty
s -> prependFailure "parsing type failed, " (typeMismatch "type" s)
data ConnectedUser =
CUUser UserId
| CUPublic
deriving (Eq, Show)
instance Hashable ConnectedUser where
hashWithSalt salt (CUUser userId) = hashWithSalt salt ("cuuser" :: Text, userId)
hashWithSalt salt CUPublic = hashWithSalt salt ("cupublic" :: Text)
newtype WSKeyConnection = WSKeyConnection (ByteString, WS.Connection)
instance Hashable WSKeyConnection where
hashWithSalt salt (WSKeyConnection (key, _conn)) = hashWithSalt salt key
instance Eq WSKeyConnection where
(==) (WSKeyConnection (key1, _conn1)) (WSKeyConnection (key2, _conn2)) = key1 == key2
instance Show WSKeyConnection where
showsPrec d (WSKeyConnection (key, _conn)) = showsPrec d $ "WSKeyConnection " <> key
showWSKeyConnection :: WSKeyConnection -> Text
showWSKeyConnection ws = "WSKeyConnection " <> show (wsKey ws)
wsKey :: WSKeyConnection -> ByteString
wsKey (WSKeyConnection (key, _conn)) = key
wsConn :: WSKeyConnection -> WS.Connection
wsConn (WSKeyConnection (_key, conn)) = conn
data Subscription =
Subscription {
s_connected_user :: ConnectedUser
, s_ws_key_connection :: WSKeyConnection
, s_topic :: Topic }
deriving (Eq, Show)
instance Hashable Subscription where
hashWithSalt salt (Subscription { .. }) =
hashWithSalt salt ( s_connected_user, s_ws_key_connection, s_topic )
subKey :: Subscription -> ByteString
subKey sub = wsKey $ s_ws_key_connection sub
type Token = Text
{-
We accept requests for subscription/unsubscription via websocket.
We could instead handle 1 websocket connection per every topic
subscription (e.g. parse headers in WS.PendingConnection. However, WS
by default can handle 65k concurrent connections. With multiple users
having multiple components open, we could exhaust that limit quickly.
Hence, we architect this to have 1 websocket connection per web
browser.
-}
data WSRequest =
WSSubscribe Topic
| WSUnsubscribe Topic
| WSAuthorize Token
| WSDeauthorize
deriving (Eq, Show)
instance FromJSON WSRequest where
parseJSON = Aeson.withObject "WSRequest" $ \o -> do
request <- o .: "request"
case request of
"subscribe" -> do
topic <- o .: "topic"
pure $ WSSubscribe topic
"unsubscribe" -> do
topic <- o .: "topic"
pure $ WSUnsubscribe topic
"authorize" -> do
token <- o .: "token"
pure $ WSAuthorize token
"deauthorize" -> pure $ WSDeauthorize
s -> prependFailure "parsing request type failed, " (typeMismatch "request" s)
-- | For tests mainly
instance ToJSON WSRequest where
toJSON (WSSubscribe topic) = Aeson.object [ "request" .= ( "subscribe":: Text )
, "topic" .= topic ]
toJSON (WSUnsubscribe topic) = Aeson.object [ "request" .= ( "unsubscribe" :: Text )
, "topic" .= topic ]
toJSON (WSAuthorize token) = Aeson.object [ "request" .= ( "authorize" :: Text )
, "token" .= token ]
toJSON WSDeauthorize = Aeson.object [ "request" .= ( "deauthorize" :: Text ) ]
data Dispatcher =
Dispatcher { d_subscriptions :: SSet.Set Subscription
-- , d_ws_server :: WSAPI AsServer
, d_ce_listener :: ThreadId
}
class HasDispatcher env where
hasDispatcher :: Getter env Dispatcher
-- | A notification is sent to clients who subscribed to specific topics
data Notification =
Notification Topic Message
deriving (Show)
instance ToJSON Notification where
toJSON (Notification topic message) = Aeson.object [
"notification" .= toJSON (Aeson.object [
"topic" .= toJSON topic
, "message" .= toJSON message
])
]
src/Gargantext/Core/AsyncUpdates/Dispatcher/WebSocket.hs 0 → 100644
View file @ 3e499383
{-|
Module : Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket
Description : Dispatcher websocket server
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
-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.Core.AsyncUpdates.Dispatcher.WebSocket where
import Control.Concurrent.Async qualified as Async
import Control.Lens (view)
import Data.Aeson qualified as Aeson
import Data.UUID.V4 as UUID
import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(_auth_user_id))
import Gargantext.API.Admin.Types (HasSettings(settings), Settings, jwtSettings)
import Gargantext.API.Prelude (IsGargServer)
import Gargantext.Core.AsyncUpdates.Dispatcher.Subscriptions
import Gargantext.Core.AsyncUpdates.Dispatcher.Types
import Gargantext.Prelude
import Gargantext.System.Logging (LogLevel(DEBUG), logMsg, withLogger)
import Network.WebSockets qualified as WS
import Servant
import Servant.API.WebSocket qualified as WS (WebSocketPending)
import Servant.Auth.Server (verifyJWT)
import Servant.Server.Generic (AsServerT)
import StmContainers.Set as SSet
newtype WSAPI mode = WSAPI {
wsAPIServer :: mode :- "ws" :> Summary "WebSocket endpoint" :> WS.WebSocketPending
} deriving Generic
wsServer :: ( IsGargServer env err m, HasDispatcher env, HasSettings env ) => WSAPI (AsServerT m)
wsServer = WSAPI { wsAPIServer = streamData }
where
streamData :: ( IsGargServer env err m, HasDispatcher env, HasSettings env )
=> WS.PendingConnection -> m ()
streamData pc = do
authSettings <- view settings
d <- view hasDispatcher
let subscriptions = d_subscriptions d
key <- getWSKey pc
c <- liftBase $ WS.acceptRequest pc
let ws = WSKeyConnection (key, c)
_ <- liftBase $ Async.concurrently (wsLoop authSettings subscriptions ws) (pingLoop ws)
-- _ <- liftIO $ Async.withAsync (pure ()) (\_ -> wsLoop ws)
pure ()
-- | Send a ping control frame periodically, otherwise the
-- | connection is dropped. NOTE that 'onPing' message is not
-- | supported in the JS API: either the browser supports this or
-- | not:
-- | https://stackoverflow.com/questions/10585355/sending-websocket-ping-pong-frame-from-browser
pingLoop :: WSKeyConnection -> IO ()
pingLoop ws = do
forever $ do
-- WS.sendDataMessage (wsConn ws) (WS.Text (Aeson.encode Ping) Nothing)
WS.sendPing (wsConn ws) ("" :: Text)
threadDelay $ 10 * 1000000
wsLoop :: Settings -> SSet.Set Subscription -> WSKeyConnection -> IO a
wsLoop authSettings subscriptions ws = flip finally disconnect $ do
withLogger () $ \ioLogger -> do
logMsg ioLogger DEBUG "[wsLoop] connecting"
wsLoop' CUPublic ioLogger
where
wsLoop' user ioLogger = do
dm <- WS.receiveDataMessage (wsConn ws)
newUser <- case dm of
WS.Text dm' _ -> do
case Aeson.decode dm' of
Nothing -> do
logMsg ioLogger DEBUG $ "[wsLoop] unknown message: " <> show dm'
return user
Just (WSSubscribe topic) -> do
-- TODO Fix s_connected_user based on header
let sub = Subscription { s_connected_user = user
, s_ws_key_connection = ws
, s_topic = topic }
_ss <- insertSubscription subscriptions sub
-- putText $ "[wsLoop] subscriptions: " <> show (showSub <$> ss)
return user
Just (WSUnsubscribe topic) -> do
let sub = Subscription { s_connected_user = user
, s_ws_key_connection = ws
, s_topic = topic }
_ss <- removeSubscription subscriptions sub
-- putText $ "[wsLoop] subscriptions: " <> show (showSub <$> ss)
return user
Just (WSAuthorize token) -> do
let jwtS = authSettings ^. jwtSettings
mUser <- liftBase $ verifyJWT jwtS (encodeUtf8 token)
logMsg ioLogger DEBUG $ "[wsLoop] authorized user: " <> show mUser
-- TODO Update my subscriptions!
return $ fromMaybe user (CUUser . _auth_user_id <$> mUser)
Just WSDeauthorize -> do
-- TODO Update my subscriptions!
pure CUPublic
_ -> do
logMsg ioLogger DEBUG "[wsLoop] binary ws messages not supported"
return user
wsLoop' newUser ioLogger
disconnect = do
withLogger () $ \ioLogger -> do
logMsg ioLogger DEBUG "[wsLoop] disconnecting..."
_ss <- removeSubscriptionsForWSKey subscriptions ws
-- putText $ "[wsLoop] subscriptions: " <> show (show <$> ss)
return ()
getWSKey :: MonadBase IO m => WS.PendingConnection -> m ByteString
getWSKey pc = do
let reqHead = WS.pendingRequest pc
-- WebSocket specification says that a pending request should send
-- some unique, Sec-WebSocket-Key string. We use this to compare
-- connections (WS.Connection doesn't implement an Eq instance).
let mKey = head $ filter (\(k, _) -> k == "Sec-WebSocket-Key") $ WS.requestHeaders reqHead
let key' = snd $ fromMaybe (panicTrace "Sec-WebSocket-Key not found!") mKey
-- Unfortunately, a single browsers sends the same
-- Sec-WebSocket-Key so we want to make that even more unique.
uuid <- liftBase $ UUID.nextRandom
let key = key' <> "-" <> show uuid
liftBase $ putText $ "[getWSKey] request headers: " <> (show $ WS.requestHeaders reqHead)
pure key
src/Gargantext/Core/AsyncUpdates/Nanomsg.hs 0 → 100644
View file @ 3e499383
{-|
Module : Gargantext.Core.AsyncUpdates.Nanomsg
Description : Nanomsg utils
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.Nanomsg where
import Gargantext.Prelude
import Nanomsg
withSafeSocket :: SocketType a => Text -> a -> (Socket a -> IO c) -> IO c
withSafeSocket socketName t =
bracket onOpen onClose
where
onOpen = do
s <- socket t
setRcvBuf s 1
setSndBuf s 1
rcvBufInt <- rcvBuf s
sndBufInt <- sndBuf s
putText $ "[" <> socketName <> "] rcvBuf: " <> show rcvBufInt <> ", sndBuf: " <> show sndBufInt
pure s
onClose s = do
close s
panicTrace $ "[withSafeSocket] " <> socketName <> " closed"
src/Gargantext/Core/Methods/Similarities/Accelerate/Distributional.hs
View file @ 3e499383
......@@ -85,7 +85,6 @@ where $n_{ij}$ is the cooccurrence between term $i$ and term $j$
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GADTs #-}
module Gargantext.Core.Methods.Similarities.Accelerate.Distributional
where
......
src/Gargantext/Core/Text/Corpus/Parsers/Wikidata/Crawler.hs
View file @ 3e499383
......@@ -11,8 +11,6 @@ Thx to Alp Well Typed for the first version.
-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Core.Text.Corpus.Parsers.Wikidata.Crawler
where
......
src/Gargantext/Core/Text/Corpus/Query.hs
View file @ 3e499383
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Gargantext.Core.Text.Corpus.Query (
Query -- * opaque
, RawQuery(..)
......
src/Gargantext/Core/Text/List/Social.hs
View file @ 3e499383
......@@ -83,6 +83,7 @@ instance ToSchema FlowSocialListWith where
instance FromHttpApiData FlowSocialListWith
where
parseUrlPiece "My lists first" = pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
parseUrlPiece "MySelfFirst" = pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
parseUrlPiece "Others lists first" = pure $ FlowSocialListWithPriority { fslw_priority = OthersFirst }
parseUrlPiece "NoList" = pure $ NoList True
parseUrlPiece x = panicTrace $ "[G.C.T.L.Social] TODO FromHttpApiData FlowSocialListWith error: " <> (show x)
......
src/Gargantext/Core/Text/Prepare.hs
View file @ 3e499383
......@@ -15,8 +15,6 @@ that could be the incarnation of the mythic Gargantua.
-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Core.Text.Prepare
where
......
src/Gargantext/Core/Text/Terms/Mono/Stem/Internal/Lancaster.hs
View file @ 3e499383
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Core.Text.Terms.Mono.Stem.Internal.Lancaster
( stem
......
src/Gargantext/Core/Text/Terms/Multi.hs
View file @ 3e499383
......@@ -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/Core/Types.hs
View file @ 3e499383
......@@ -14,8 +14,8 @@ commentary with @some markup@.
{-# OPTIONS_GHC -fno-warn-deprecations #-}
------------------------------------------------------------------------
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
, module Gargantext.Database.Admin.Types.Node
......
src/Gargantext/Core/Types/Main.hs
View file @ 3e499383
......@@ -19,6 +19,7 @@ module Gargantext.Core.Types.Main where
------------------------------------------------------------------------
import Data.Bimap (Bimap)
import Data.Bimap qualified as Bimap
import Data.Swagger ( ToSchema(..), ToParamSchema, genericDeclareNamedSchema )
import Data.Text (unpack, pack)
import Data.TreeDiff
......@@ -29,7 +30,6 @@ import Gargantext.Prelude
import Servant.API (FromHttpApiData(..), ToHttpApiData(..))
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import qualified Data.Bimap as Bimap
type CorpusName = Text
------------------------------------------------------------------------
......
src/Gargantext/Core/Viz/Graph/API.hs
View file @ 3e499383
......@@ -297,3 +297,18 @@ getGraphGexf :: HasNodeStory env err m
getGraphGexf nId = do
HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph nId
pure $ addHeader "attachment; filename=graph.gexf" graph
------------------------------------------------------------
updateGraphLegend :: HasNodeError err
=> NodeId
-> GraphLegendAPI
-> DBCmd err NodeId
updateGraphLegend nId (GraphLegendAPI lg ) = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
case graph of
Nothing -> pure nId
Just g -> do
let graph' = set (graph_metadata . _Just . gm_legend) lg g
_ <- updateHyperdata nId (HyperdataGraph (Just graph') (nodeGraph ^. node_hyperdata . hyperdataCamera))
pure nId
src/Gargantext/Core/Viz/Graph/Types.hs
View file @ 3e499383
......@@ -241,6 +241,20 @@ instance FromField HyperdataGraphAPI
fromField = fromField'
-----------------------------------------------------------
data GraphLegendAPI = GraphLegendAPI [LegendField]
deriving (Show, Generic)
$(deriveJSON (unPrefix "_graphAPI") ''GraphLegendAPI)
instance ToSchema GraphLegendAPI where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graphAPI")
makeLenses ''GraphLegendAPI
instance FromField GraphLegendAPI
where
fromField = fromField'
---------------------- defaults
......
src/Gargantext/Core/Viz/Types.hs
View file @ 3e499383
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Viz.Types where
......@@ -10,13 +5,12 @@ module Gargantext.Core.Viz.Types where
import Data.Aeson.TH (deriveJSON)
import Data.Swagger
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Vector qualified as V
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Protolude
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
---------------
-- | Chart | --
---------------
......
src/Gargantext/Database/Action/Delete.hs
View file @ 3e499383
......@@ -20,6 +20,7 @@ module Gargantext.Database.Action.Delete
import Control.Lens (view)
import Data.Text (unpack)
import Gargantext.Core (HasDBid(..))
import Gargantext.Core.AsyncUpdates.CentralExchange.Types (ce_notify, CEMessage(..))
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Share (delFolderTeam)
import Gargantext.Database.Action.User (getUserId)
......@@ -43,7 +44,7 @@ deleteNode :: (CmdCommon env, HasNodeError err)
-> Cmd' env err Int
deleteNode u nodeId = do
node' <- N.getNode nodeId
case (view node_typename node') of
num <- case (view node_typename node') of
nt | nt == toDBid NodeUser -> panicTrace "[G.D.A.D.deleteNode] Not allowed to delete NodeUser (yet)"
nt | nt == toDBid NodeTeam -> do
uId <- getUserId u
......@@ -57,6 +58,14 @@ deleteNode u nodeId = do
N.deleteNode nodeId
_ -> N.deleteNode nodeId
-- | Node was deleted, refresh its parent (if exists)
-- mapM_ (CE.ce_notify . CE.UpdateTreeFirstLevel) nodeIds
case view node_parent_id node' of
Nothing -> return ()
Just pId -> ce_notify $ UpdateTreeFirstLevel pId
return num
-- if hasNodeType node' NodeUser
-- then panic "Not allowed to delete NodeUser (yet)"
-- else if hasNodeType node' NodeTeam
......
src/Gargantext/Database/Action/Flow.hs
View file @ 3e499383
......@@ -65,6 +65,7 @@ import Data.Text qualified as T
import EPO.API.Client.Types qualified as EPO
import Gargantext.API.Ngrams.Tools (getTermsWith)
import Gargantext.Core (Lang(..), NLPServerConfig, withDefaultLanguage)
import Gargantext.Core.AsyncUpdates.CentralExchange.Types (HasCentralExchangeNotification(ce_notify), CEMessage(..))
import Gargantext.Core.Ext.IMTUser (readFile_Annuaire)
import Gargantext.Core.NLP (HasNLPServer, nlpServerGet)
import Gargantext.Core.NodeStory.Types (HasNodeStory)
......@@ -167,6 +168,7 @@ flowDataText :: forall env err m.
, HasValidationError err
, MonadJobStatus m
, HasSettings env
, HasCentralExchangeNotification env
)
=> User
-> DataText
......@@ -197,7 +199,7 @@ flowAnnuaire :: ( DbCmd' env err m
, HasValidationError err
, MonadJobStatus m
, HasSettings env
)
, HasCentralExchangeNotification env )
=> MkCorpusUser
-> TermType Lang
-> FilePath
......@@ -217,7 +219,7 @@ flowCorpusFile :: ( DbCmd' env err m
, HasValidationError err
, MonadJobStatus m
, HasSettings env
)
, HasCentralExchangeNotification env )
=> MkCorpusUser
-> Limit -- Limit the number of docs (for dev purpose)
-> TermType Lang
......@@ -248,7 +250,7 @@ flowCorpus :: ( DbCmd' env err m
, FlowCorpus a
, MonadJobStatus m
, HasSettings env
)
, HasCentralExchangeNotification env )
=> MkCorpusUser
-> TermType Lang
-> Maybe FlowSocialListWith
......@@ -269,6 +271,7 @@ flow :: forall env err m a c.
, MkCorpus c
, MonadJobStatus m
, HasSettings env
, HasCentralExchangeNotification env
)
=> Maybe c
-> MkCorpusUser
......@@ -282,7 +285,7 @@ flow c mkCorpusUser la mfslw (count, docsC) jobHandle = do
-- TODO if public insertMasterDocs else insertUserDocs
nlpServer <- view $ nlpServerGet (_tt_lang la)
runConduit $ zipSources (yieldMany ([1..] :: [Int])) docsC
.| CList.chunksOf 100
.| CList.chunksOf 2
.| mapM_C (addDocumentsWithProgress nlpServer userCorpusId)
.| sinkNull
......@@ -321,6 +324,7 @@ addDocumentsToHyperCorpus ncs mb_hyper la corpusId docs = do
------------------------------------------------------------------------
createNodes :: ( DbCmd' env err m, HasNodeError err, HasSettings env
, MkCorpus c
, HasCentralExchangeNotification env
)
=> MkCorpusUser
-> Maybe c
......@@ -339,6 +343,9 @@ createNodes mkCorpusUser ctype = do
_ <- insertDefaultNodeIfNotExists NodeGraph userCorpusId userId
-- _ <- insertDefaultNodeIfNotExists NodeDashboard userCorpusId userId
ce_notify $ UpdateTreeFirstLevel listId
ce_notify $ UpdateTreeFirstLevel userCorpusId
pure (userId, userCorpusId, listId)
......
src/Gargantext/Database/Action/Metrics/NgramsByContext.hs
View file @ 3e499383
......@@ -127,7 +127,8 @@ getOccByNgramsOnlyFast cId lId nt = do
WITH cnnv AS
( SELECT DISTINCT context_node_ngrams.context_id,
context_node_ngrams.ngrams_id,
nodes_contexts.node_id
nodes_contexts.node_id,
nodes_contexts.category
FROM nodes_contexts
JOIN context_node_ngrams ON context_node_ngrams.context_id = nodes_contexts.context_id
),
......@@ -135,7 +136,7 @@ getOccByNgramsOnlyFast cId lId nt = do
(SELECT context_id, ngrams_id, terms
FROM cnnv
JOIN ngrams ON cnnv.ngrams_id = ngrams.id
WHERE node_id = ?
WHERE node_id = ? AND cnnv.category > 0
),
ncids_agg AS
(SELECT ngrams_id, terms, array_agg(DISTINCT context_id) AS agg
......
src/Gargantext/Database/Action/Metrics/TFICF.hs
View file @ 3e499383
......@@ -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/Database/Action/Search.hs
View file @ 3e499383
......@@ -61,7 +61,9 @@ import Opaleye.TextSearch
--
queryToTsSearch :: API.Query -> Field SqlTSQuery
queryToTsSearch q = sqlToTSQuery $ T.unpack $ API.interpretQuery q transformAST
queryToTsSearch q =
let (dictionary, transformed) = API.interpretQuery q transformAST
in sqlToTSQuery dictionary (T.unpack transformed)
where
-- It's important to understand how things work under the hood: When we perform
......@@ -97,29 +99,45 @@ queryToTsSearch q = sqlToTSQuery $ T.unpack $ API.interpretQuery q transformAST
API.QT_partial_match (Term term)
-> stem EN GargPorterAlgorithm term <> ":*"
transformAST :: BoolExpr [API.QueryTerm] -> T.Text
-- Transforms the input query terms and returns the full SQL query to feed Postgres AND
-- the dictionary to use, see: https://www.postgresql.org/docs/current/textsearch-dictionaries.html
-- In a nutshell, if we have a partial match operator in our query, we use the \"simple\" dictionary
-- under the hood, which won't filter stop words, which are sometimes useful, see issue #265.
transformAST :: BoolExpr [API.QueryTerm] -> (Maybe Dictionary, T.Text)
transformAST ast = case ast of
BAnd sub1 sub2
-> " (" <> transformAST sub1 <> " & " <> transformAST sub2 <> ") "
-> let (d1, sub1Expr) = transformAST sub1
(d2, sub2Expr) = transformAST sub2
in (d1 <|> d2, " (" <> sub1Expr <> " & " <> sub2Expr <> ") ")
BOr sub1 sub2
-> " (" <> transformAST sub1 <> " | " <> transformAST sub2 <> ") "
-> let (d1, sub1Expr) = transformAST sub1
(d2, sub2Expr) = transformAST sub2
in (d1 <|> d2, " (" <> sub1Expr <> " | " <> sub2Expr <> ") ")
BNot (BConst (Negative term))
-> transformAST (BConst (Positive term)) -- double negation
BNot sub
-> "!" <> transformAST sub
-> second (\e -> "!" <> e) $ transformAST sub
-- BTrue cannot happen is the query parser doesn't support parsing 'TRUE' alone.
BTrue
-> T.empty
-> (Nothing, T.empty)
-- BTrue cannot happen is the query parser doesn't support parsing 'FALSE' alone.
BFalse
-> T.empty
-> (Nothing, T.empty)
BConst (Positive queryTerms)
-> renderQueryTerms queryTerms
-> (pickDictionary queryTerms, renderQueryTerms queryTerms)
-- We can handle negatives via `ANDNOT` with itself.
BConst (Negative queryTerms)
-> "!" <> renderQueryTerms queryTerms
-> (pickDictionary queryTerms, "!" <> renderQueryTerms queryTerms)
pickDictionary :: [API.QueryTerm] -> Maybe Dictionary
pickDictionary qs = if any isPartialMatch qs then Just (Dictionary "simple") else Nothing
where
isPartialMatch :: API.QueryTerm -> Bool
isPartialMatch = \case
API.QT_partial_match{} -> True
_ -> False
------------------------------------------------------------------------
searchDocInDatabase :: HasDBid NodeType
=> ParentId
......
src/Gargantext/Database/Admin/Types/Hyperdata/Any.hs
View file @ 3e499383
......@@ -9,13 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata.Any
......
src/Gargantext/Database/Admin/Types/Hyperdata/Contact.hs
View file @ 3e499383
......@@ -12,13 +12,7 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
......@@ -27,7 +21,7 @@ module Gargantext.Database.Admin.Types.Hyperdata.Contact
import Data.Morpheus.Types (GQLType(..))
import Data.Time.Segment (jour)
import Gargantext.API.GraphQL.Utils qualified as GAGU
import Gargantext.API.GraphQL.UnPrefix qualified as GAGU
import Gargantext.Core.Text (HasText(..))
import Gargantext.Database.Admin.Types.Hyperdata.Prelude
import Gargantext.Prelude
......
src/Gargantext/Database/Admin/Types/Hyperdata/Corpus.hs
View file @ 3e499383
......@@ -9,13 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata.Corpus
......
src/Gargantext/Database/Admin/Types/Hyperdata/CorpusField.hs
View file @ 3e499383
......@@ -9,10 +9,7 @@ Portability : POSIX
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata.CorpusField
where
......
src/Gargantext/Database/Admin/Types/Hyperdata/Dashboard.hs
View file @ 3e499383
......@@ -9,12 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
......
src/Gargantext/Database/Admin/Types/Hyperdata/Default.hs
View file @ 3e499383
......@@ -9,13 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata.Default
......
src/Gargantext/Database/Admin/Types/Hyperdata/Document.hs
View file @ 3e499383
......@@ -9,13 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata.Document where
......
src/Gargantext/Database/Admin/Types/Hyperdata/File.hs
View file @ 3e499383
......@@ -9,13 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata.File
......
src/Gargantext/Database/Admin/Types/Hyperdata/Folder.hs
View file @ 3e499383
......@@ -9,13 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata.Folder
......
src/Gargantext/Database/Admin/Types/Hyperdata/List.hs
View file @ 3e499383
......@@ -9,13 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata.List
......
src/Gargantext/Database/Admin/Types/Hyperdata/Model.hs
View file @ 3e499383
......@@ -9,13 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata.Model
......
src/Gargantext/Database/Admin/Types/Hyperdata/Phylo.hs
View file @ 3e499383
......@@ -9,13 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata.Phylo
......
src/Gargantext/Database/Admin/Types/Hyperdata/Texts.hs
View file @ 3e499383
......@@ -9,13 +9,6 @@ Portability : POSIX
-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata.Texts
......
src/Gargantext/Database/Admin/Types/Node.hs
View file @ 3e499383
This diff is collapsed.
src/Gargantext/Database/Prelude.hs
View file @ 3e499383
This diff is collapsed.
src/Gargantext/Database/Query/Table/Node.hs
View file @ 3e499383
This diff is collapsed.
src/Gargantext/Database/Schema/User.hs
View file @ 3e499383
This diff is collapsed.
src/Gargantext/Utils/Jobs/Internal.hs
View file @ 3e499383
This diff is collapsed.
src/Gargantext/Utils/Jobs/Map.hs
View file @ 3e499383
This diff is collapsed.
src/Gargantext/Utils/Jobs/Monad.hs
View file @ 3e499383
This diff is collapsed.
src/Gargantext/Utils/UTCTime.hs
View file @ 3e499383
This diff is collapsed.
stack.yaml
View file @ 3e499383
This diff is collapsed.
test-data/ngrams/GarganText_DocsList-nodeId-177.json 0 → 100644
View file @ 3e499383
This diff is collapsed.
test/Test/API.hs
View file @ 3e499383
This diff is collapsed.
test/Test/API/Errors.hs
View file @ 3e499383
This diff is collapsed.
test/Test/API/GraphQL.hs
View file @ 3e499383
This diff is collapsed.
test/Test/API/Notifications.hs 0 → 100644
View file @ 3e499383
This diff is collapsed.
test/Test/API/Private.hs
View file @ 3e499383
This diff is collapsed.
test/Test/API/Private/Share.hs
View file @ 3e499383
This diff is collapsed.
test/Test/API/Routes.hs
View file @ 3e499383
This diff is collapsed.
test/Test/API/Setup.hs
View file @ 3e499383
This diff is collapsed.
test/Test/API/UpdateList.hs
View file @ 3e499383
This diff is collapsed.
test/Test/Core/AsyncUpdates.hs 0 → 100644
View file @ 3e499383
This diff is collapsed.
test/Test/Core/Text/Corpus/Query.hs
View file @ 3e499383
This diff is collapsed.
test/Test/Database/Operations.hs
View file @ 3e499383
This diff is collapsed.
test/Test/Database/Operations/NodeStory.hs
View file @ 3e499383
This diff is collapsed.
test/Test/Instances.hs 0 → 100644
View file @ 3e499383
This diff is collapsed.
test/Test/Ngrams/Query.hs
View file @ 3e499383
This diff is collapsed.
test/Test/Offline/JSON.hs
View file @ 3e499383
This diff is collapsed.
test/Test/Offline/Phylo.hs
View file @ 3e499383
This diff is collapsed.
test/Test/Utils.hs
View file @ 3e499383
This diff is collapsed.
test/Test/Utils/Jobs.hs
View file @ 3e499383
This diff is collapsed.
test/drivers/hspec/Main.hs
View file @ 3e499383
This diff is collapsed.
test/drivers/tasty/Main.hs
View file @ 3e499383
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment