Verified Commit 39f8f17d authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski

Merge branch 'dev' into 341-dev-websockets

parents 69ed7b65 c262ec0e
## Version 0.0.7.1.14
* [BACK][FIX][Write Frame microservice proxy improvements (#364)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/364)
## Version 0.0.7.1.13
* [FRONT][ERGO][[Node Phylo] Default initial behaviour on clicking a Phylo node for the 1st time (#582)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/582)
* [BACK][PROXY][Enabling the microservices proxy trigger endless "Refresh to update" modals (#374)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/374)
* [BACK][REFACT][[REFACTORING] renaming Corpus to Document for HAL related file (#372)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/372)
## Version 0.0.7.1.12
* [BACK][INFRA][Microservices notes proxy doesn't work with local CodiMD (#370)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/370)
* [BACK][DOC][[Documentation] Document development tooling (#371)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/371)
## Version 0.0.7.1.11
* [BACK][SECURITY][Allow the microservices proxy to be disabled or enabled by configuration settings (#369)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/369)
## Version 0.0.7.1.10
* [BACK][FIX][Improving message error from the TSV import (#361)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/361)
* [BACK][FIX][Creation of corpus from HAL's API crash (#366)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/366)
* [BACK][FIX][[Documentation] Improve README (#365)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/365)
## Version 0.0.7.1.9
* [BACK][FIX][Write Frame microservice proxy improvements (#364)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/364)
......
......@@ -40,55 +40,85 @@ You must have the following installed:
Clone both the backend (`haskell-gargantext`), and the frontend (`purescript-gargantext`) at the root of the backend.
```shell
git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
cd haskell-gargantext
git clone https://gitlab.iscpif.fr/gargantext/purescript-gargantext.git
cd ..
$ git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
$ cd haskell-gargantext
$ git clone https://gitlab.iscpif.fr/gargantext/purescript-gargantext.git
$ cd ..
```
#### Enter a Nix shell
#### The Nix shell
Enter a Nix shell. This will take a long time the first time you run it:
In what follows, many commands need to be executed from within the Nix shell. To make that clear, those will be prefixed with `n$`, *but you must not actually type `n$` before the commands*.
To enter a Nix shell, run the following (this will take a moment the first time you run it, be patient):
```shell
nix-shell
$ nix-shell
```
Once you are in a Nix shell, you can run commands like you would in any other shell.
You can exit a Nix shell at any point with `exit`.
In what follows, many commands need to be executed from within the Nix shell. To make that clear, those will be prefixed with `n$`, *but you must not actually type `n$` before the commands*.
At any point, you can exit a Nix shell and go back to your regular shell by running `exit`.
If for some reason you do not want to enter a Nix shell, you can still run a command from outside:
If for some reason you do not want to enter a Nix shell, you can still run a command from outside: running the following in a non-Nix shell
```shell
nix-shell --run "my command"
$ nix-shell --run "my command"
```
is equivalent to running `my command` from within a Nix shell.
#### Disable optimization flags
#### (Optional) Disable optimization flags
Make a file `cabal.project.local` that will tell Cabal to turn off optimizations:
If you are developing Gargantext, you might be interested in disabling compiler optimizations.
This speeds up compilation, but the compiled program itself will be less efficient.
To disable compiler optimizations, copy the file `cabal.project.local_toCopy` (which contains the flags that disable optimizations) into `cabal.project.local` (which will be read by Cabal):
```shell
cp cabal.project.local_toCopy cabal.project.local
$ cp cabal.project.local_toCopy cabal.project.local
```
#### Install backend dependencies
#### Build the frontend
```shell
$ cd purescript-gargantext/
$ ./bin/install
$ cd ..
```
#### Build the backend
*Note: This project can be built with either stack or cabal. We keep the `cabal.project` up-to-date, which allows us to build with cabal by default but we support stack thanks to thanks to `cabal2stack`, which allows us to generate a valid `stack.yaml` from a `cabal.project`. Due to the fact gargantext requires a particular set of system dependencies (C++ libraries, toolchains, etc) we use nix to setup an environment with all the required system dependencies, in a sandboxed and isolated fashion.*
*This documentation shows how to build with cabal. For information related to stack, see `docs/using_stack.md`.*
**From within the Nix shell**, run:
Depending on your situation, there are several ways to build the project:
1. **Simple build**
*This will build the project and install the executables `gargantext-cli` and `gargantext-server` somewhere on your system.
Depending on your Cabal configuration, this is probably `~/.local/bin/` or `~/.cabal/bin/`.*
From within the Nix shell, run:
```shell
n$ cabal update
n$ cabal install
```
#### Build the backend and frontend
2. **Full build**
*Same as "simple build" above, but also runs tests and builds documentation.*
Just run the `install` script:
```shell
$ ./bin/install
```
3. **Build and run**
*Builds and runs the Gargantext server. This has the advantage of letting you run Gargantext without having to know where on your machine the executable is.*
*Since you will be running Gargantext,* **you need to have gone through initialization first;** *see "Initializing and running" below.*
From inside a Nix shell:
```shell
./bin/install
cd purescript-gargantext/
./bin/install
cd ..
n$ cabal run gargantext-server -- --ini gargantext.ini --run Prod
```
### Initializing and running
......@@ -96,8 +126,8 @@ cd ..
#### Start containers for database and NLP software bricks
```shell
cd devops/docker
docker compose up
$ cd devops/docker
$ docker compose up
```
The initialization schema should be loaded automatically from `devops/postgres/schema.sql`.
......@@ -105,7 +135,7 @@ The initialization schema should be loaded automatically from `devops/postgres/s
#### Create configuration file
```shell
cp gargantext.ini_toModify gargantext.ini
$ cp gargantext.ini_toModify gargantext.ini
```
> `.gitignore` excludes this file, so you don't need to worry about committing it by mistake, and you can change the passwords in `gargantext.ini` safely.
......@@ -121,24 +151,25 @@ The master user's name is automatically set to `gargantua`, but you will be prom
#### Running
From inside a Nix shell:
Make sure you know where `gargantext-server` is (probably in `~/.local/bin/` or `.cabal/bin/`). If the location is in your `$PATH`, just run:
```shell
n$ cabal run gargantext-server -- --ini gargantext.ini --run Prod
$ gargantext-server -- --ini gargantext.ini --run Prod
```
(If the location is not in your `$PATH`, just prefix `gargantext-server` with the path to it.)
If you are working on the backend, you might want to use the `./start` script: it rebuilds the backend, starts the docker containers, and launches the Gargantext server at once.
You might want to use the `./start` script: it rebuilds the backend, starts the docker containers, and launches the Gargantext server at once.
### Running tests
From nix shell:
```
cabal v2-test --test-show-details=streaming
```shell
n$ cabal v2-test --test-show-details=streaming
```
Or, from "outside":
```
nix-shell --run "cabal v2-test --test-show-details=streaming"
```shell
$ nix-shell --run "cabal v2-test --test-show-details=streaming"
```
### Working on libraries
......@@ -157,12 +188,19 @@ When a devlopment is needed on libraries (for instance, the HAL crawler in https
> Note: without `stack.yaml` we would have to only fix `cabal.project` -> `source-repository-package` commit id. Sha256 is there to make sure CI reruns the tests.
### Tooling info
Once you get Gargantext to compile and run on your machine, you will likely want
the following:
- Language support (intellisense) in your editor; see `docs/editor_setup.md`
- Being able to send commands to the Gargantext server from GHCI; see `docs/running_commands.md`
## Use Cases <a name="use-cases"></a>
### Multi-User with Graphical User Interface (Server Mode)
``` sh
~/.local/bin/stack --docker exec gargantext-server -- --ini "gargantext.ini" --run Prod
``` shell
$ ~/.local/bin/stack --docker exec gargantext-server -- --ini "gargantext.ini" --run Prod
```
Then you can log in with `user1` / `1resu`
......@@ -172,23 +210,23 @@ Then you can log in with `user1` / `1resu`
#### Simple cooccurrences computation and indexation from a list of Ngrams
``` sh
stack --docker exec gargantext-cli -- CorpusFromGarg.csv ListFromGarg.csv Ouput.json
``` shell
$ stack --docker exec gargantext-cli -- CorpusFromGarg.csv ListFromGarg.csv Ouput.json
```
### Analyzing the ngrams table repo
We store the repository in directory `repos` in the [CBOR](https://cbor.io/) file format. To decode it to JSON and analyze, say, using [jq](https://shapeshed.com/jq-json/), use the following command:
``` sh
cat repos/repo.cbor.v5 | stack exec gargantext-cbor2json | jq .
``` shell
$ cat repos/repo.cbor.v5 | stack exec gargantext-cbor2json | jq .
```
### Documentation
To build documentation, run:
```sh
stack build --haddock --no-haddock-deps --fast
```shell
$ stack build --haddock --no-haddock-deps --fast
```
(in `.stack-work/dist/x86_64-linux-nix/Cabal-3.2.1.0/doc/html/gargantext`).
......@@ -233,24 +271,24 @@ Playground is located at http://localhost:8008/gql
https://www.cloudytuts.com/tutorials/docker/how-to-upgrade-postgresql-in-docker-and-kubernetes/
To upgrade PostgreSQL in Docker containers, for example from 11.x to 14.x, simply run:
```sh
docker exec -it <container-id> pg_dumpall -U gargantua > 11-db.dump
```shell
$ docker exec -it <container-id> pg_dumpall -U gargantua > 11-db.dump
```
Then, shut down the container, replace `image` section in `devops/docker/docker-compose.yaml` with `postgres:14`. Also, it is a good practice to create a new volume, say `garg-pgdata14` and bind the new container to it. If you want to keep the same volume, remember about removing it like so:
```sh
docker-compose rm postgres
docker volume rm docker_garg-pgdata
```shell
$ docker-compose rm postgres
$ docker volume rm docker_garg-pgdata
```
Now, start the container and execute:
```sh
# need to drop the empty DB first, since schema will be created when restoring the dump
docker exec -i <new-container-id> dropdb -U gargantua gargandbV5
# recreate the db, but empty with no schema
docker exec -i <new-container-id> createdb -U gargantua gargandbV5
# now we can restore the dump
docker exec -i <new-container-id> psql -U gargantua -d gargandbV5 < 11-db.dump
```shell
$ # need to drop the empty DB first, since schema will be created when restoring the dump
$ docker exec -i <new-container-id> dropdb -U gargantua gargandbV5
$ # recreate the db, but empty with no schema
$ docker exec -i <new-container-id> createdb -U gargantua gargandbV5
$ # now we can restore the dump
$ docker exec -i <new-container-id> psql -U gargantua -d gargandbV5 < 11-db.dump
```
### Upgrading using
......@@ -258,25 +296,25 @@ docker exec -i <new-container-id> psql -U gargantua -d gargandbV5 < 11-db.dump
There is a solution using pgupgrade_cluster but you need to manage the clusters version 14 and 13. Hence here is a simple solution to upgrade.
First save your data:
```
sudo su postgres
pg_dumpall > gargandb.dump
```shell
$ sudo su postgres
$ pg_dumpall > gargandb.dump
```
Upgrade postgresql:
```
sudo apt install postgresql-server-14 postgresql-client-14
sudo apt remove --purge postgresql-13
```shell
$ sudo apt install postgresql-server-14 postgresql-client-14
$ sudo apt remove --purge postgresql-13
```
Restore your data:
```
sudo su postgres
psql < gargandb.dump
```shell
$ sudo su postgres
$ psql < gargandb.dump
```
Maybe you need to restore the gargantua password
```
ALTER ROLE gargantua PASSWORD 'yourPasswordIn_gargantext.ini'
```shell
$ ALTER ROLE gargantua PASSWORD 'yourPasswordIn_gargantext.ini'
```
Maybe you need to change the port to 5433 for database connection in your gargantext.ini file.
......
......@@ -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 = []
......
......@@ -93,7 +93,7 @@ source-repository-package
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/crawlers/hal.git
tag: 3a7d039e07c8564e8ff84ef88480924d18aa5018
tag: 1dbd939257d33126e49d2679375553df1f2eebc5
source-repository-package
type: git
......
......@@ -93,6 +93,7 @@ constraints: any.Cabal ==3.8.1.0,
any.c2hs ==0.28.8,
c2hs +base3 -regression,
any.cabal-doctest ==1.0.9,
any.cache ==0.1.3.0,
any.call-stack ==0.4.0,
any.case-insensitive ==1.2.1.0,
any.cassava ==0.5.3.0,
......@@ -277,6 +278,7 @@ constraints: any.Cabal ==3.8.1.0,
any.hspec-wai ==0.11.1,
any.hspec-wai-json ==0.11.0,
any.hstatistics ==0.3.1,
any.http-accept ==0.2,
any.http-api-data ==0.5,
http-api-data -use-text-show,
any.http-client ==0.7.14,
......@@ -555,6 +557,8 @@ constraints: any.Cabal ==3.8.1.0,
streaming-commons -use-bytestring-builder,
any.strict ==0.5,
any.string-conversions ==0.4.0.1,
any.stringsearch ==0.3.6.6,
stringsearch -base3 +base4,
any.swagger2 ==2.8.7,
any.syb ==0.7.2.4,
any.system-cxx-std-lib ==1.0,
......@@ -664,6 +668,7 @@ constraints: any.Cabal ==3.8.1.0,
any.wai-extra ==3.1.13.0,
wai-extra -build-example,
any.wai-logger ==2.4.0,
any.wai-util ==0.8,
any.wai-websockets ==3.0.1.2,
wai-websockets +example,
any.warp ==3.3.25,
......
Editor Setup
=============
This document tells you how to turn VSCodium into a Haskell integrated
development environment (IDE). Hopefully, the process looks roughly the same
with any editor that supports the language server protocol (LSP).
1. Install [the VSCodium editor](https://vscodium.com/#install)
2. Install [direnv](https://direnv.net/docs/installation.html) on your system
3. Install [GHCup](https://www.haskell.org/ghcup/install/).
During the installation process, it will ask you whether to install
haskell-language-server (HLS); accept.
4. Install the following VSCodium extensions using VSCodium's built-in
package manager (the "Extensions" tab on the left):
- [direnv](https://open-vsx.org/vscode/item?itemName=mkhl.direnv).
Warning: there are several extensions with that name; choose the one by `mkhl`
- [Haskell](https://open-vsx.org/vscode/item?itemName=haskell.haskell)
Restart VSCodium, open the `haskell-gargantext` project. Wait a few seconds;
you might get a popup telling you that GHCup needs to download some version
of GHC; accept.
Now *if everything went well*, you should have Haskell intellisense working
in your editor: hover over a symbol to get its type and documentation,
right-click a symbol and click "Jump to definition" to jump to its definition,
etc.
Sadly, there is a good chance that something did go wrong. To help you
troubleshoot, here's a rundown of what should have happened under the hood when
you opened the project — assuming I didn't misunderstand anything:
1. The `direnv` extension sees the `.envrc` file at the root of the project,
and sets the environment variables accordingly (all `.envrc` actually says
is to use a Nix shell).
2. The `haskell` extension looks up what version of GHC is needed and tells that
to GHCup.
3. If needed, GHCup downloads the right version of GHC for the project and adds
it to its collection of GHC compilers in `~/.ghcup/ghc/`
4. Now the `haskell` extension has everything it needs.
Things to try if something goes wrong
--------------------------------------
- Make sure that you have compiled the project before.
- The current HLS version might be too recent to work with your GHC version.
To check that and use an adequate HLS version:
- Check out the project's GHC version around the beginning of `cabal.project`;
- Look up the corresponding "Last supporting HLS version" in [this table](https://haskell-language-server.readthedocs.io/en/latest/support/ghc-version-support.html#current-ghc-version-support-status).
For instance, if the project's GHC version is 9.4.7, you need HLS v2.5.0.0 *at most*.
- Tell GHCup to compile the corresponding version of HLS based the corresponding version of GHC,
with the following command (again, using GHC 9.4.7 as an example):
```shell
$ ghcup compile hls --version 2.5.0.0 --ghc 9.4.7
```
Now in principle the VSCodium `haskell` extension should have everything
it needs to provide Intellisense.
Running commands from the REPL
===============================
You can interact with the Gargantext server directly from GHCI, the Haskell REPL.
This saves you the need to have the frontend running, and it allows you
to interact directly using types and functions defined in the backend source.
Launching and setting up the REPL
----------------------------------
**From within a Nix shell** (as indicated here by the `n$` prompt —
don't type it!), run:
```shell
n$ cabal repl
```
Wait for the Gargantext modules to compile. You're now in GHCI.
Import the custom prelude, as well as the `runCmdReplServantErr` function:
```haskell
ghci> import Gargantext.Prelude
ghci> import Gargantext.API.Dev (runCmdReplServantErr)
```
> `runCmdReplServantErr` is a variant of the `runCmd` function (defined in
> `Gargantext.Database.Prelude`) designed to be called directly from the REPL.
You might miss some symbols not in the Gargantext prelude, such as `String`.
If you need such symbols, you can of course just import them directly, like so:
```haskell
ghci> import GHC.Base (String)
```
Running commands
-----------------
Make sure that:
- The database is up,
- The Gargantext server is running locally.
Write the command you want to run by defining a value of type
`Cmd'' DevEnv ServerError a`, then apply `runCmdReplServantErr` to it and run
the resulting action from within the REPL.
The server should have run teh command and updated the database accordingly.
Saving your REPL setup
-----------------------
To avoid typing all of that every time, and saving your own helper functions,
you can define your own module somewhere in the hierarchy. For instance,
you could write something like
```haskell
module Gargantext.ReplHelper where
import Gargantext.Prelude
import Gargantext.API.Dev (runCmdReplServantErr)
import GHC.Base (String)
runMyCustomCommand :: IO ()
runMyCustomCommand = runCmdReplServantErr ... -- insert your command here
```
in `src/Gargantext/ReplHelper.hs`. You'll also need to edit `gargantext.cabal`
to tell it about your new module:
```cabal
...
library
import:
defaults
exposed-modules:
Gargantext.ReplHelper
Gargantext
Gargantext.API
...
```
Once you have added/edited your REPL helper module, you can live-reload
and import it from within GHCI:
```haskell
ghci> :r
ghci> import Gargantext.ReplHelper
```
Alternatively, restarting GHCI will reload the module, but it will also recompile
everything.
......@@ -16,10 +16,11 @@ allowed-origins = [
, "https://dev.sub.gargantext.org"
, "http://localhost:8008"
, "http://localhost:8108"
, "http://localhost:3000"
]
use-origins-for-hosts = true
[microservices]
proxy-port = 8009
[microservices.proxy]
port = 8009
enabled = false
......@@ -5,7 +5,7 @@ cabal-version: 3.4
-- see: https://github.com/sol/hpack
name: gargantext
version: 0.0.7.1.9
version: 0.0.7.1.14
synopsis: Search, map, share
description: Please see README.md
category: Data
......@@ -530,10 +530,12 @@ library
, blaze-svg ^>= 0.3.6.1
, boolexpr ^>= 0.2
, bytestring ^>= 0.10.12.0
, cache >= 0.1.3.0
, case-insensitive ^>= 1.2.1.0
, cassava ^>= 0.5.2.0
, cborg ^>= 0.2.6.0
, cereal ^>= 0.5.8.2
, clock >= 0.8
, conduit ^>= 1.3.4.2
, conduit-extra ^>= 1.3.5
, containers ^>= 0.6.5.1
......@@ -676,6 +678,7 @@ library
, 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
, tagsoup ^>= 0.14.8
......@@ -703,6 +706,7 @@ library
, wai-app-static ^>= 3.1.7.3
, wai-cors ^>= 0.2.7
, wai-extra ^>= 3.1.8
, wai-util >= 0.8
, wai-websockets ^>= 3.0.1.2
, warp ^>= 3.3.20
, websockets ^>= 0.12.7.3
......@@ -761,6 +765,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
......@@ -813,9 +818,90 @@ executable gargantext-central-exchange
, unordered-containers ^>= 0.2.16.0
, vector ^>= 0.7.3
common testDependencies
build-depends:
base >=4.7 && <5
, QuickCheck ^>= 2.14.2
, aeson ^>= 1.5.6.0
, aeson-pretty ^>= 0.8.9
, aeson-qq
, async ^>= 2.2.4
, boolexpr ^>= 0.2
, bytestring ^>= 0.10.12.0
, cache >= 0.1.3.0
, case-insensitive
, conduit ^>= 1.3.4.2
, containers ^>= 0.6.5.1
, crawlerArxiv
, cryptohash
, directory
, extra ^>= 1.7.9
, fast-logger ^>= 3.0.5
, fmt
, gargantext
, gargantext-prelude
, graphviz ^>= 2999.20.1.0
, hspec ^>= 2.7.10
, hspec-core
, hspec-expectations >= 0.8 && < 0.9
, hspec-wai
, hspec-wai-json
, http-api-data
, http-client ^>= 0.6.4.1
, http-client-tls ^>= 0.3.5.3
, http-types
, lens >= 5.2.2 && < 5.3
, monad-control >= 1.0.3 && < 1.1
, mtl ^>= 2.2.2
, network-uri
, parsec ^>= 3.1.14.0
, patches-class ^>= 0.1.0.1
, patches-map ^>= 0.1.0.1
, postgres-options >= 0.2 && < 0.3
, postgresql-simple >= 0.6.4 && < 0.7
, pretty
, process ^>= 1.6.13.2
, protolude ^>= 0.3.3
, quickcheck-instances ^>= 0.3.25.2
, raw-strings-qq
, recover-rtti >= 0.4 && < 0.5
, resource-pool >= 0.2.3.2 && < 0.2.4
, servant-auth
, servant-auth
, servant-auth-client
, servant-client
, servant-client-core
, servant-job
, servant-server
, shelly >= 1.9 && < 2
, split
, stm ^>= 2.5.0.1
, streaming-commons
, tasty ^>= 1.4.2.1
, tasty-golden
, 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
, unicode-collation >= 0.1.3.6
, unliftio
, unordered-containers ^>= 0.2.16.0
, utf8-string ^>= 1.0.2
, validity ^>= 0.11.0.1
, vector ^>= 0.12.3.0
, wai
, wai-extra
, warp
test-suite garg-test-tasty
import:
defaults
defaults
, testDependencies
type: exitcode-stdio-1.0
main-is: drivers/tasty/Main.hs
other-modules:
......@@ -826,6 +912,7 @@ test-suite garg-test-tasty
Test.Core.Similarity
Test.Core.Text
Test.Core.Text.Corpus.Query
Test.Core.Text.Corpus.TSV
Test.Core.Text.Examples
Test.Core.Text.Flow
Test.Core.Utils
......@@ -904,8 +991,7 @@ test-suite garg-test-tasty
, raw-strings-qq
, recover-rtti >= 0.4 && < 0.5
, resource-pool >= 0.2.3.2 && < 0.2.4
, servant >= 0.18.3 && < 0.20
, servant-auth
-- , servant >= 0.18.3 && < 0.20
, servant-auth
, servant-auth-client
, servant-client
......@@ -939,7 +1025,8 @@ test-suite garg-test-tasty
test-suite garg-test-hspec
import:
defaults
defaults
, testDependencies
type: exitcode-stdio-1.0
main-is: drivers/hspec/Main.hs
other-modules:
......@@ -950,6 +1037,7 @@ test-suite garg-test-hspec
Test.API.GraphQL
Test.API.Notifications
Test.API.Private
Test.API.Private.Share
Test.API.Routes
Test.API.Setup
Test.API.UpdateList
......@@ -1003,7 +1091,7 @@ test-suite garg-test-hspec
, raw-strings-qq
, recover-rtti >= 0.4 && < 0.5
, resource-pool >= 0.2.3.2 && < 0.2.4
, servant >= 0.18.3 && < 0.20
-- , servant >= 0.18.3 && < 0.20
, servant-auth
, servant-auth-client
, servant-client
......
......@@ -37,7 +37,9 @@ module Gargantext.API
import Control.Concurrent
import Control.Concurrent.Async qualified as Async
import Control.Lens hiding (Level)
import Data.Cache qualified as InMemory
import Data.List (lookup)
import Data.Set qualified as Set
import Data.Text (pack)
import Data.Text.Encoding qualified as TE
import Data.Text.IO (putStrLn)
......@@ -65,6 +67,8 @@ import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.RequestLogger
-- 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
......@@ -80,7 +84,8 @@ startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logge
periodicActions <- schedulePeriodicActions env
let runServer = run port (mid app) `finally` stopGargantext periodicActions
let runProxy = run proxyPort (mid (microServicesProxyApp env))
proxyCache <- InMemory.newCache (Just oneHour)
let runProxy = run proxyPort (mid (microServicesProxyApp proxyCache env))
Async.race_ runServer runProxy
......@@ -92,6 +97,7 @@ startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logge
_ -> panicTrace $
"You must run 'gargantext-init " <> pack (_IniFile iniFile) <>
"' before running gargantext-server (only the first time)."
oneHour = Clock.fromNanoSecs 3600_000_000_000
portRouteInfo :: PortNumber -> PortNumber -> IO ()
portRouteInfo mainPort proxyPort = do
......@@ -158,7 +164,7 @@ makeGargMiddleware :: CORSSettings -> Mode -> IO Middleware
makeGargMiddleware crsSettings mode = do
let corsMiddleware = cors $ \_incomingRq -> Just
simpleCorsResourcePolicy
{ corsOrigins = Just (map mkCorsOrigin (crsSettings ^. corsAllowedOrigins), True)
{ corsOrigins = Just $ (Set.toList $ Set.fromList $ map mkCorsOrigin (crsSettings ^. corsAllowedOrigins), True)
, corsMethods = [ methodGet , methodPost , methodPut
, methodDelete, methodOptions, methodHead]
, corsIgnoreFailures = False
......@@ -172,7 +178,7 @@ makeGargMiddleware crsSettings mode = do
pure $ loggerMiddleware . corsMiddleware
where
mkCorsOrigin :: CORSOrigin -> Origin
mkCorsOrigin = TE.encodeUtf8 . _CORSOrigin
mkCorsOrigin (CORSOrigin u) = TE.encodeUtf8 . pack . showBaseUrl $ u
---------------------------------------------------------------------
-- | API Global
......
......@@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Gargantext.API.Admin.Settings.CORS where
import Prelude
......@@ -10,10 +11,11 @@ import Control.Arrow
import Data.Text qualified as T
import Toml
import Control.Lens hiding (iso, (.=))
import Data.String (IsString)
import Servant.Client.Core
import Data.Maybe (fromMaybe)
newtype CORSOrigin = CORSOrigin { _CORSOrigin :: T.Text }
deriving (Show, Eq, IsString)
newtype CORSOrigin = CORSOrigin { _CORSOrigin :: BaseUrl }
deriving (Show, Eq)
data CORSSettings =
CORSSettings {
......@@ -30,7 +32,8 @@ corsOriginCodec :: TomlBiMap CORSOrigin AnyValue
corsOriginCodec = _Orig >>> _Text
where
_Orig :: BiMap e CORSOrigin T.Text
_Orig = iso _CORSOrigin CORSOrigin
_Orig = iso (T.pack . showBaseUrl . _CORSOrigin)
(\(T.unpack -> u) -> CORSOrigin . fromMaybe (error $ "invalid origin: " <> u) . parseBaseUrl $ u)
corsSettingsCodec :: TomlCodec CORSSettings
corsSettingsCodec = CORSSettings
......
......@@ -13,12 +13,14 @@ import Toml
data MicroServicesSettings =
MicroServicesSettings {
-- | The port where the microservices proxy will be listening on.
_msProxyPort :: Int
_msProxyPort :: !Int
, _msProxyEnabled :: !Bool
} deriving (Show, Eq)
microServicesSettingsCodec :: TomlCodec MicroServicesSettings
microServicesSettingsCodec = MicroServicesSettings
<$> Toml.int "proxy-port" .= _msProxyPort
<$> Toml.int "port" .= _msProxyPort
<*> Toml.bool "enabled" .= _msProxyEnabled
mkProxyUrl :: GargConfig -> MicroServicesSettings -> BaseUrl
mkProxyUrl GargConfig{..} MicroServicesSettings{..} =
......
......@@ -22,7 +22,7 @@ makeLenses ''GargTomlSettings
settingsCodec :: TomlCodec GargTomlSettings
settingsCodec = GargTomlSettings
<$> (Toml.table corsSettingsCodec "cors" .= _gargCorsSettings)
<*> (Toml.table microServicesSettingsCodec "microservices" .= _gargMicroServicesSettings)
<*> (Toml.table microServicesSettingsCodec "microservices.proxy" .= _gargMicroServicesSettings)
-- | Extends the 'allowed-origins' in the CORSettings with the URLs embellished
-- with the proxy port.
......@@ -33,9 +33,7 @@ addProxyToAllowedOrigins stgs =
addProxies :: Int -> CORSSettings -> CORSSettings
addProxies port cors =
let origins = _corsAllowedOrigins cors
mkUrl (CORSOrigin u) = case parseBaseUrl (T.unpack u) of
Nothing -> CORSOrigin u
Just bh -> CORSOrigin $ T.pack $ showBaseUrl $ bh { baseUrlPort = port }
mkUrl (CORSOrigin bh) = CORSOrigin $ bh { baseUrlPort = port }
in cors { _corsAllowedOrigins = origins <> Prelude.map mkUrl origins }
-- | Loads the 'CORSSettings' from the 'toml' file.
......@@ -48,5 +46,7 @@ loadGargTomlSettings tomlFile = do
logMsg ioLogger ERROR $ T.unpack $ "Error, gargantext-settings.toml parsing failed: " <> Toml.prettyTomlDecodeErrors errs
panicTrace "Please fix the errors in your gargantext-settings.toml file."
Right settings0 -> case settings0 ^. gargCorsSettings . corsUseOriginsForHosts of
True -> pure $ addProxyToAllowedOrigins $ settings0 & over (gargCorsSettings . corsAllowedHosts) (\_ -> "http://localhost:3000" : (settings0 ^. gargCorsSettings . corsAllowedOrigins))
False -> pure $ addProxyToAllowedOrigins $ settings0 & over (gargCorsSettings . corsAllowedHosts) ("http://localhost:3000" :)
True -> pure $ addProxyToAllowedOrigins $
settings0 & over (gargCorsSettings . corsAllowedHosts)
(\_ -> (settings0 ^. gargCorsSettings . corsAllowedOrigins))
False -> pure $ addProxyToAllowedOrigins settings0
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
module Gargantext.API.Node.ShareURL where
import Data.Text
import Gargantext.Prelude
import Control.Lens
import Data.Text qualified as T
import Data.Validity qualified as V
import Gargantext.API.Admin.Types (appPort, settings, Settings)
import Gargantext.API.Prelude
import Gargantext.Core.Types (NodeType, NodeId, unNodeId)
import Gargantext.Database.Prelude (HasConfig (hasConfig), CmdCommon)
import Control.Lens.Getter (view)
import Gargantext.Core.Config (gc_url)
import Gargantext.API.Routes.Named.Share qualified as Named
import Gargantext.Core.Config (gc_url, GargConfig)
import Gargantext.Core.Types (NodeType, NodeId, unNodeId, _ValidationError)
import Gargantext.Database.Prelude (HasConfig (hasConfig), CmdCommon)
import Gargantext.Prelude
import Network.URI (parseURI)
import Prelude (String)
import Servant.Server.Generic (AsServerT)
shareURL :: IsGargServer env err m => Named.ShareURL (AsServerT m)
......@@ -19,14 +24,33 @@ shareURL = Named.ShareURL getUrl
getUrl :: (IsGargServer env err m, CmdCommon env)
=> Maybe NodeType
-> Maybe NodeId
-> m Text
-> m Named.ShareLink
getUrl nt id = do
-- TODO add check that the node is able to be shared (in a shared folder)
case nt of
Nothing -> pure "Invalid node Type"
Just t ->
case id of
Nothing -> pure "Invalid node ID"
Just i -> do
url <- view $ hasConfig . gc_url
pure $ url <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
-- TODO add check that the node is able to be shared (in a shared folder)
gc <- view hasConfig
urlPort <- view settings
case get_url nt id gc urlPort of
Left err -> throwError $ _ValidationError # (V.check False err)
Right shareLink -> pure shareLink
get_url :: Maybe NodeType
-> Maybe NodeId
-> GargConfig
-> Settings
-> Either String Named.ShareLink
get_url nt id gc stgs = do
let urlHost = T.unpack $ gc ^. gc_url
let urlPort = stgs ^. appPort
t <- maybe (Left "Invalid node Type") Right nt
i <- maybe (Left "Invalid node ID") Right id
-- Include the port the server is running on if this is
-- localhost, so that share URLs would work out of the box.
let !rawURL
| "localhost" `isInfixOf` urlHost
= urlHost <> ":" <> show urlPort <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
| otherwise
= urlHost <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
maybe (Left $ "Couldn't construct a valid share URL from '" <> rawURL <> "'")
(Right . Named.ShareLink)
(parseURI rawURL)
......@@ -92,7 +92,7 @@ data GargPrivateAPI' mode = GargPrivateAPI'
, listGetAPI :: mode :- NamedRoutes List.GETAPI
, listJsonAPI :: mode :- NamedRoutes List.JSONAPI
, listTsvAPI :: mode :- NamedRoutes List.TSVAPI
, shareUrlEp :: mode :- "shareurl" :> NamedRoutes ShareURL
, shareUrlAPI :: mode :- "shareurl" :> NamedRoutes ShareURL
} deriving Generic
......
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
module Gargantext.API.Routes.Named.Share (
-- * Routes types
ShareNode(..)
, Unpublish(..)
, ShareURL(..)
, ShareLink(..)
, renderShareLink
-- * API types (which appears in the routes)
, ShareNodeParams(..)
) where
import Data.Text (Text)
import Data.Aeson
import Data.Swagger
import Data.Text qualified as T
import GHC.Generics
import Gargantext.API.Node.Share.Types ( ShareNodeParams (..) )
import Gargantext.Database.Admin.Types.Node
import Network.URI (parseURI)
import Prelude
import Servant
-- | A shareable link.
-- N.B. We don't use a 'BareUrl' internally, because parsing something like
-- 'http://localhost/#/share/NodeCorpus/16'
-- would fail because '#/share/NodeCorpus/16' by the RFC3968 spec is considered
-- an uriFragment, but BaseUrl cannot handle that.
newtype ShareLink = ShareLink { getShareLink :: URI }
deriving (Show, Eq, Ord)
renderShareLink :: ShareLink -> T.Text
renderShareLink = T.pack . show . getShareLink
instance ToJSON ShareLink where
toJSON = toJSON . renderShareLink
instance FromJSON ShareLink where
parseJSON = withText "ShareLink" $ \txt ->
let urlStr = T.unpack txt
in case parseURI urlStr of
Nothing -> fail $ "Invalid URL: " <> urlStr
Just u -> pure $ ShareLink u
instance ToSchema ShareLink where
declareNamedSchema _ = declareNamedSchema (Proxy @T.Text)
newtype ShareURL mode = ShareURL
{ shareUrlEp :: mode :- Summary "Fetch URL for sharing a node"
:> QueryParam "type" NodeType
:> QueryParam "id" NodeId
:> Get '[JSON] Text
:> Get '[JSON] ShareLink
} deriving Generic
......
......@@ -63,5 +63,5 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
, listGetAPI = List.getAPI
, listJsonAPI = List.jsonAPI
, listTsvAPI = List.tsvAPI
, shareUrlEp = shareURL
, shareUrlAPI = shareURL
}
......@@ -36,8 +36,8 @@ instance ToSchema Value where declareNamedSchema _ = declareNamedSchema (Proxy :
-- 'purescript-gargantext' package.
data PhyloData = PhyloData { pd_corpusId :: NodeId
, pd_listId :: NodeId
, pd_data :: GraphData
, pd_config :: PhyloConfig
, pd_data :: Maybe GraphData
, pd_config :: Maybe PhyloConfig
}
deriving (Generic, Show, Eq)
......
......@@ -21,7 +21,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..
import Gargantext.Defaults qualified as Defaults
import Gargantext.Prelude hiding (intercalate)
import HAL qualified
import HAL.Doc.Corpus qualified as HAL
import HAL.Doc.Document qualified as HAL
import HAL.Types qualified as HAL
import Servant.Client (ClientError)
......@@ -38,23 +38,23 @@ getC la q ml = do
-- Left err -> panic $ pack $ show err
-- Right (len, docsC) -> pure (len, docsC .| mapMC (toDoc' la))
toDoc' :: Maybe ISO639.ISO639_1 -> HAL.Corpus -> IO HyperdataDocument
toDoc' la (HAL.Corpus { .. }) = do
toDoc' :: Maybe ISO639.ISO639_1 -> HAL.Document -> IO HyperdataDocument
toDoc' la (HAL.Document { .. }) = do
-- printDebug "[toDoc corpus] h" h
let mDateS = _corpus_date <|> Just (pack $ show Defaults.year)
let mDateS = _document_date <|> Just (pack $ show Defaults.year)
let (utctime, (pub_year, pub_month, pub_day)) = Date.mDateSplit mDateS
let abstractDefault = unwords _corpus_abstract
let abstractDefault = unwords _document_abstract
let abstract = case la of
Nothing -> abstractDefault
Just l -> maybe abstractDefault unwords (Map.lookup l _corpus_abstract_lang_map)
Just l -> maybe abstractDefault unwords (Map.lookup l _document_abstract_lang_map)
pure HyperdataDocument { _hd_bdd = Just "Hal"
, _hd_doi = Just $ pack $ show _corpus_docid
, _hd_doi = Just $ pack $ show _document_docid
, _hd_url = Nothing
, _hd_page = Nothing
, _hd_title = Just $ unwords _corpus_title
, _hd_authors = Just $ foldl' (\x y -> if x == "" then y else x <> ", " <> y) "" _corpus_authors_names
, _hd_institutes = Just $ foldl' (\x y -> if x == "" then y else x <> ", " <> y) "" $ _corpus_authors_affiliations <> map show _corpus_struct_id
, _hd_source = Just $ maybe "Nothing" identity _corpus_source
, _hd_title = Just $ unwords _document_title
, _hd_authors = Just $ foldl' (\x y -> if x == "" then y else x <> ", " <> y) "" _document_authors_names
, _hd_institutes = Just $ foldl' (\x y -> if x == "" then y else x <> ", " <> y) "" $ _document_authors_affiliations <> map show _document_struct_id
, _hd_source = Just $ maybe "Nothing" identity _document_source
, _hd_abstract = Just abstract
, _hd_publication_date = fmap show utctime
, _hd_publication_year = pub_year
......
......@@ -20,6 +20,9 @@ import Data.ByteString.Lazy qualified as BL
import Data.Csv
import Data.Text (pack)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as TL
import Data.Text.Read qualified as DTR
import Data.Time.Segment (jour)
import Data.Vector (Vector)
import Data.Vector qualified as V
......@@ -205,7 +208,7 @@ hyperdataDocument2tsvDoc h = TsvDoc { tsv_title = m $ _hd_title h
mI = maybe 0 identity
data Delimiter = Tab | Comma
data Delimiter = Tab | Comma | Line deriving (Eq, Show)
tsvDecodeOptions :: Delimiter -> DecodeOptions
tsvDecodeOptions d = defaultDecodeOptions {decDelimiter = delimiter d}
......@@ -216,6 +219,151 @@ tsvEncodeOptions d = defaultEncodeOptions {encDelimiter = delimiter d}
delimiter :: Delimiter -> Word8
delimiter Tab = fromIntegral $ ord '\t'
delimiter Comma = fromIntegral $ ord ','
delimiter Line = fromIntegral $ ord '\n'
------------------------------------------------------------------------
testDelimiter :: Delimiter -> BL.ByteString -> Bool
testDelimiter del bs =
let x = BL.splitWith (== delimiter Line) bs
vec = V.fromList x in
case BL.splitWith (== delimiter del) <$> ((V.!?) vec 0) of
Nothing -> False
Just e -> case BL.splitWith (== delimiter del) <$> ((V.!?) vec 1) of
Nothing -> False
Just f -> length e == length f && length e > 2
findDelimiter :: BL.ByteString -> Either Text Delimiter
findDelimiter bs
| testDelimiter Tab bs = Right Tab
| testDelimiter Comma bs = Right Comma
| otherwise = Left (pack "Problem with the delimiter : be sure that the delimiter is a tabulation for each line")
isNumeric :: Text -> Either Bool Int
isNumeric str = case DTR.decimal str of
Right (x,y) -> if y == ""
then Right x
else Left False
Left _ -> Left False
lBLToText :: BL.ByteString -> Text
lBLToText b = TL.toStrict $ TL.decodeUtf8 b
validNumber :: BL.ByteString -> Text -> Int -> Either Text Bool
validNumber x columnHeader ligne = do
let number = T.replace (T.pack "\"") (T.pack "") (lBLToText x)
case isNumeric number of
Right val
| val < 0 -> Left $ ("Value of column '" <> columnHeader <> "' at line " <> pack (show ligne) <> " is negative")
|otherwise -> Right True
Left _ -> Left $ ("Error in column '" <> columnHeader <> "' at line " <> pack (show ligne) <> " : value is not a number ")
validTextField :: BL.ByteString -> Text -> Int -> Either Text Bool
validTextField x columnHeader ligne = do
let xs = T.replace (T.pack "\"\"") (T.pack "") (lBLToText x) in
if not (T.null xs)
then
if (T.length xs > 0) && ((T.length (T.filter (== '\"') xs) == 0) || ((T.head xs == '"') && (T.last xs == '"') && (T.length (T.filter (== '\"') xs) == 2)))
then return True
else Left $ ("Encapsulation problem at line " <> pack (show ligne) <> " in column '" <> columnHeader <> "' : the caracter \" must only appear at the beginning and the end of a field ")
else return True
-- else Left $ ("The column '" <> columnHeader <> "' at line " <> pack (show ligne) <> " is empty")
-- Put a warning for the user to know their is a problem (empty column)
testValue :: BL.ByteString -> Text -> Int -> Either Text Bool
testValue val columnHeader ligne = case columnHeader of
"Publication Day" -> validNumber val columnHeader ligne
"Publication Month" -> validNumber val columnHeader ligne
"Publication Year" -> validNumber val columnHeader ligne
"Authors" -> validTextField val columnHeader ligne
"Title" -> validTextField val columnHeader ligne
"Source" -> validTextField val columnHeader ligne
"Abstract" -> validTextField val columnHeader ligne
_ -> Right True
testErrorPerLine :: [BL.ByteString] -> Delimiter -> [Text] -> Int -> Either Text Bool
testErrorPerLine [] _ [] _ = Right True
testErrorPerLine _ del [] l | del == Comma = Left (pack $ "Too much field at line " <> show l <> ". Try using tabulation as a delimiter. Other delimiter like comma (,) may appear in some text.")
| otherwise = Left (pack $ "Too much field at line " <> show l)
testErrorPerLine [] _ _ l = Left (pack $ "Missing one field at line " <> show l)
testErrorPerLine (v:val) del (h:headers) ligne =
case testValue v h ligne of
Left _err -> Left _err
Right _ -> testErrorPerLine val del headers ligne
checkNextLine :: Vector BL.ByteString -> Delimiter -> [Text] -> BL.ByteString -> Int -> Either Text (Int,[BL.ByteString])
checkNextLine bl del headers res x = do
case BL.splitWith (==delimiter del) <$> ((V.!?) bl (x+1)) of
Nothing -> Right (x, (BL.splitWith (==delimiter del) res))
Just value -> if length value > 1
then Right (x, (BL.splitWith (==delimiter del) res))
else case BL.append res <$> ((V.!?) bl (x+1)) of
Nothing -> Left "checkNextLine2"
Just val -> checkNextLine bl del headers val (x+1)
getMultipleLinefile :: Vector BL.ByteString -> Delimiter -> [Text] -> BL.ByteString -> Int -> Either Text (Int,[BL.ByteString])
getMultipleLinefile bl del headers res x = do
let tmp = BL.splitWith (==delimiter del) res in
if length tmp == length headers
then checkNextLine bl del headers res x
else
if (length tmp > length headers) || (V.length bl == (x + 1))
then Left (pack $ "Cannot parse the file at line " <> show x <> ". Maybe because of a delimiter")
else do
case BL.append res <$> ((V.!?) bl (x+1)) of
Nothing -> Left "getMultipleLinefile"
Just val -> getMultipleLinefile bl del headers val (x+1)
anx :: Vector BL.ByteString -> Delimiter -> [Text] -> Int -> Either Text Delimiter
anx bl del headers x
| length bl == x = Right del
| otherwise =
case (V.!?) bl x of
Nothing -> Left "anx"
Just bs ->
case getMultipleLinefile bl del headers bs x of
Left _err -> Left _err
Right (y, val) -> case testErrorPerLine val del headers (x + 1) of
Left _err -> Left _err
Right _ -> anx bl del headers (y+1)
testIfErrorInFile :: [BL.ByteString] -> Delimiter -> [Text] -> Either Text Delimiter
testIfErrorInFile bl del headers = anx (V.fromList bl) del headers 1
testCorrectFile :: BL.ByteString -> Either Text Delimiter
testCorrectFile bs =
case findDelimiter bs of
Left _err -> Left _err
Right del -> do
let bl = BL.splitWith (==delimiter Line) bs in
case getHeaders bl del of
Left _err -> Left _err
Right headers -> testIfErrorInFile bl del headers
----------Test headers added to ggt
-- use a map to remove \r that sometimes appear at the end of a line
testAllHeadersPresence :: [Text] -> Either Text [Text]
testAllHeadersPresence headers = do
let listHeaders = filter (`notElem` (map (T.replace (T.pack "\r") (T.pack ""))headers)) ["Publication Day", "Publication Month", "Publication Year", "Authors", "Title", "Source", "Abstract"]
if null listHeaders
then Right headers
else Left ((pack " Missing column : ") <> T.intercalate ", " listHeaders)
getHeaders :: [BL.ByteString] -> Delimiter -> Either Text [Text]
getHeaders bl del = do
let vec = V.fromList bl in
case BL.splitWith (==delimiter del) <$> ((V.!?) vec 0) of
Nothing -> Left "Error getHeaders"
Just headers -> testAllHeadersPresence (map (\x -> T.replace (T.pack "\"") (T.pack "") (lBLToText x)) headers)
------------------------------------------------------------------------
......@@ -251,10 +399,10 @@ readByteStringStrict d ff = readByteStringLazy d ff . BL.fromStrict
-- | TODO use readFileLazy
readTSVFile :: FilePath -> IO (Either Text (Header, Vector TsvDoc))
readTSVFile fp = do
result <- readTsvLazyBS Comma <$> BL.readFile fp
case result of
Left _err -> readTsvLazyBS Tab <$> BL.readFile fp
Right res -> pure $ Right res
file <- BL.readFile fp
case (testCorrectFile file) of
Left _err -> pure $ Left _err
Right del -> pure $ readTsvLazyBS del file
......
......@@ -28,7 +28,6 @@ import Gargantext.Core.Types.Phylo (GraphData(..))
import Gargantext.Core.Viz.LegacyPhylo hiding (Phylo(..))
import Gargantext.Core.Viz.Phylo (PhyloConfig(..), defaultConfig, _phylo_param, _phyloParam_config)
import Gargantext.Core.Viz.Phylo.API.Tools
import Gargantext.Core.Viz.Phylo.Example (phyloCleopatre)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, defaultList)
......@@ -58,21 +57,27 @@ getPhylo phyloId = Named.GetPhylo $ \lId _level _minSizeBranch -> do
listId <- case lId of
Nothing -> defaultList corpusId
Just ld -> pure ld
(gd, phyloConfig) <- getPhyloDataJson phyloId
pd <- getPhyloDataJson phyloId
-- printDebug "getPhylo" theData
pure $ PhyloData corpusId listId gd phyloConfig
case pd of
Nothing -> pure $ PhyloData corpusId listId Nothing Nothing
Just (gd, phyloConfig) ->
pure $ PhyloData corpusId listId (Just gd) (Just phyloConfig)
getPhyloDataJson :: PhyloId -> GargNoServer (GraphData, PhyloConfig)
getPhyloDataJson :: PhyloId -> GargNoServer (Maybe (GraphData, PhyloConfig))
getPhyloDataJson phyloId = do
maybePhyloData <- getPhyloData phyloId
let phyloData = fromMaybe phyloCleopatre maybePhyloData
let phyloConfig = _phyloParam_config $ _phylo_param phyloData
phyloJson <- liftBase $ phylo2dot2json phyloData
case parseEither parseJSON phyloJson of
Left err -> panicTrace $ T.pack $ "[Gargantext.Core.Viz.Phylo.API] getPhyloDataJson: " <> err
Right gd -> pure (gd, phyloConfig)
phyloData <- getPhyloData phyloId
phyloJson <- liftBase $ maybePhylo2dot2json phyloData
case phyloJson of
Nothing -> pure Nothing
Just pj ->
case parseEither parseJSON pj of
Left err -> panicTrace $ T.pack $ "[Gargantext.Core.Viz.Phylo.API] getPhyloDataJson: " <> err
Right gd -> pure $ Just (gd, phyloConfig phyloData)
where
phyloConfig phyloData = _phyloParam_config . _phylo_param $ fromMaybe (panicTrace "[Gargantext.Core.Viz.Phylo.API] getPhyloDataJson: no phylo data") phyloData
-- getPhyloDataSVG phId _lId l msb = do
......
......@@ -69,6 +69,10 @@ savePhylo :: PhyloId -> DBCmd err ()
savePhylo = undefined
--------------------------------------------------------------------
maybePhylo2dot2json :: Maybe Phylo -> IO (Maybe Value)
maybePhylo2dot2json Nothing = pure Nothing
maybePhylo2dot2json (Just phylo) = Just <$> phylo2dot2json phylo
phylo2dot2json :: Phylo -> IO Value
phylo2dot2json phylo = do
withTempDirectory "/tmp" "phylo" $ \dirPath -> do
......
......@@ -25,6 +25,7 @@ import Data.Text qualified as T
import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.API.Admin.Types (settings, _microservicesSettings, HasSettings)
import Gargantext.Core
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Core.Types (Name)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Hyperdata.Default
......@@ -34,7 +35,6 @@ import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Prelude hiding (hash)
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Prelude.Crypto.Hash (hash)
import Servant.Client.Core.BaseUrl
......@@ -96,8 +96,14 @@ mkNodeWithParent_ConfigureHyperdata NodeFrameNotebook (Just i) uId name = (:[])
mkNodeWithParent_ConfigureHyperdata _ _ _ _ = nodeError NotImplYet
internalNotesProxy :: BaseUrl -> T.Text
internalNotesProxy proxyUrl = T.pack $ showBaseUrl proxyUrl <> "/notes"
-- | Creates the base URL for the notes microservices proxy, or defaults
-- to the notes microservice if the proxy has been disabled from the settings.
internalNotesProxy :: GargConfig -> MicroServicesSettings -> T.Text
internalNotesProxy cfg msSettings
| _msProxyEnabled msSettings = T.pack $ showBaseUrl proxyUrl <> "/notes"
| otherwise = _gc_frame_write_url cfg
where
proxyUrl = mkProxyUrl cfg msSettings
-- | Function not exposed
mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType, HasSettings env)
......@@ -116,7 +122,7 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
cfg <- view hasConfig
stt <- view settings
u <- case nt of
Notes -> pure $ internalNotesProxy (mkProxyUrl cfg $ _microservicesSettings stt)
Notes -> pure $ internalNotesProxy cfg (_microservicesSettings stt)
Calc -> pure $ _gc_frame_calc_url cfg
NodeFrameVisio -> pure $ _gc_frame_visio_url cfg
_ -> nodeError NeedsConfiguration
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Gargantext.MicroServices.ReverseProxy (
microServicesProxyApp
......@@ -24,34 +25,41 @@ import Conduit
import Data.ByteString qualified as B
import Data.ByteString.Builder
import Data.ByteString.Char8 qualified as C8
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Search qualified as BS
import Data.Cache qualified as InMemory
import Data.Conduit.List qualified as CC
import Data.String
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import GHC.Generics
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.API.Admin.Types
import Gargantext.API.Node.ShareURL qualified as Share
import Gargantext.API.Routes.Named.Private
import Gargantext.API.Routes.Named.Share (ShareLink(..))
import Gargantext.API.ThrowAll (throwAllRoutes)
import Gargantext.API.Types (HTML)
import Gargantext.Core.Config (gc_frame_write_url)
import Gargantext.Database.Admin.Types.Node (NodeType(..), NodeId (..))
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Prelude hiding (Handler)
import Network.HTTP.ReverseProxy
import Network.HTTP.Types (hCacheControl, RequestHeaders, hReferer, ResponseHeaders, Header)
import Network.HTTP.Types.Header (hHost)
import Network.HTTP.Types.Header (hHost, hSetCookie)
import Network.HTTP.Types.Status (status302)
import Network.Wai
import Network.Wai.Util (redirect')
import Servant hiding (Header)
import Servant.Auth.Server
import Servant.Auth.Server.Internal.AddSetCookie
import Servant.Auth.Swagger ()
import Servant.Client.Core.BaseUrl
import Servant.Server.Generic
import Text.RE.Replace hiding (Capture)
import Text.RE.TDFA.ByteString
import Text.RawString.QQ (r)
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Servant.Auth.Server.Internal.AddSetCookie
import Network.Wai
-- See https://github.com/haskell-servant/servant/issues/1601#issue-1338013029
instance {-# OVERLAPPING #-}
......@@ -66,7 +74,7 @@ instance {-# OVERLAPPING #-}
--
newtype FrameId = FrameId { _FrameId :: T.Text }
deriving (Show, Eq, Ord)
deriving (Show, Eq, Ord, Hashable)
instance ToHttpApiData FrameId where
toUrlPiece = toUrlPiece . _FrameId
......@@ -122,7 +130,7 @@ data NotesProxy mode = NotesProxy
-- | The config file which contains the server settings for the websocket connection
-- that we have to overwrite with our settings.
, configFile :: mode :- "config" :> Get '[HTML] T.Text
, configFile :: mode :- "config" :> Raw
-- | Once the connection has been established, this is the websocket endpoint to
-- poll edits.
......@@ -132,7 +140,9 @@ data NotesProxy mode = NotesProxy
, meEndpoint :: mode :- "me" :> Raw
-- | The initial endpoint which will be hit the first time we want to access the /notes endpoint.
, notesEp :: mode :- Capture "frameId" FrameId :> Raw
, notesEp :: mode :- Capture "frameId" FrameId
:> QueryParam "node_id" NodeId
:> Raw
-- | The generic routes serving the assets.
, notesStaticAssets :: mode :- Raw
......@@ -146,48 +156,68 @@ data SocketIOProxy mode = SocketIOProxy
-- The Server
--
microServicesProxyApp :: Env -> Application
microServicesProxyApp env = genericServeTWithContext id (server env) cfg
type ProxyCache = InMemory.Cache FrameId NodeId
microServicesProxyApp :: ProxyCache -> Env -> Application
microServicesProxyApp cache env = genericServeTWithContext id (server cache env) cfg
where
cfg :: Context AuthContext
cfg = env ^. settings . jwtSettings
:. env ^. settings . cookieSettings
:. EmptyContext
server :: Env -> ReverseProxyAPI (AsServerT Handler)
server env = ReverseProxyAPI {
server :: ProxyCache -> Env -> ReverseProxyAPI (AsServerT Handler)
server cache env = ReverseProxyAPI {
notesServiceProxy = \case
(Authenticated _autUser) -> notesProxyImplementation env
_ -> throwAllRoutes err401 $ notesProxyImplementation env
(Authenticated _autUser) -> notesProxyImplementation cache env
_ -> throwAllRoutes err401 $ notesProxyImplementation cache env
, proxyPassAll = proxyPassServer ST_notes env
}
-- | A customised configuration file that the \"notes\" service would otherwise send us, that
-- | Customise the configuration file that the \"notes\" service would otherwise send us, that
-- overrides the 'urlpath' to contain the proper service path, so that the websocket connection
-- can be started correctly. If we do not override the 'urlpath', due to the way things work
-- internally, the Javascript of CodiMD would otherwise take the first slice of the URL path
-- (something like `/notes/<frameId>`) and use /that/ as the <frameId>, which would be wrong
-- as it would try to establish a connection to `noteId=notes`.
configJS :: BaseUrl -> ServiceType -> T.Text
configJS bu st = T.pack $ [r|
window.domain = '|] <> (baseUrlHost bu) <> [r|'
window.urlpath = '|] <> renderServiceType st <> [r|'
window.debug = false
window.version = '1.2.0'
customiseConfigJS :: BaseUrl -> ServiceType -> ConduitT B.ByteString (Flush Builder) IO ()
customiseConfigJS bu st = CC.map flushReplace
where
-- Replaces the relative links in the proxied page content with proper urls.
flushReplace :: B.ByteString -> Flush Builder
flushReplace = Chunk . byteString . replaceWindowDomain . replaceUrlPath
replaceWindowDomain :: B.ByteString -> B.ByteString
replaceWindowDomain htmlBlob =
replaceAllCaptures ALL makeAbsolute $ htmlBlob *=~
[re|window.domain.*=*'.*'$|]
where
makeAbsolute _ _loc cap = case capturedText cap of
_ -> Just $ C8.pack $ "window.domain = '" <> (baseUrlHost bu) <> "'"
window.allowedUploadMimeTypes = ["image/jpeg","image/png","image/jpg","image/gif","image/svg+xml"]
replaceUrlPath :: B.ByteString -> B.ByteString
replaceUrlPath htmlBlob =
replaceAllCaptures ALL makeAbsolute $ htmlBlob *=~
[re|window.urlpath.*=*'.*'$|]
where
makeAbsolute _ _loc cap = case capturedText cap of
_ -> Just $ C8.pack $ "window.urlpath = '" <> renderServiceType st <> "'"
window.DROPBOX_APP_KEY = ''
|]
configFileSettings :: Env -> ServiceType -> WaiProxySettings
configFileSettings env sty =
defaultWaiProxySettings
{ wpsProcessBody = \_req _res -> Just $ customiseConfigJS (proxyUrl env) sty
}
notesProxyImplementation :: Env -> NotesProxy AsServer
notesProxyImplementation env = NotesProxy {
notesProxyImplementation :: ProxyCache -> Env -> NotesProxy AsServer
notesProxyImplementation cache env = NotesProxy {
slideEp = \frameId -> slideProxyServer env frameId
, publishEp = \frameId -> publishProxyServer env frameId
, configFile = pure $ configJS (proxyUrl env) sty
, publishEp = \frameId -> publishProxyServer cache env frameId
, configFile = defaultForwardServerWithSettings sty id env (configFileSettings env sty)
, notesSocket = socketIOProxyImplementation sty env
, meEndpoint = proxyPassServer sty env
, notesEp = \_frameId -> defaultForwardServer sty id env
, notesEp = \frameId mbNodeId -> notesForwardServer cache frameId mbNodeId sty id env
, notesStaticAssets = proxyPassServer sty env
}
where
......@@ -196,7 +226,7 @@ notesProxyImplementation env = NotesProxy {
socketIOProxyImplementation :: ServiceType -> Env -> SocketIOProxy AsServer
socketIOProxyImplementation sty env = SocketIOProxy {
socketIoEp = \_noteId -> defaultForwardServer sty id env
socketIoEp = \_noteId -> defaultForwardServer sty id id env
}
removeServiceFromPath :: ServiceType -> Request -> Request
......@@ -208,21 +238,42 @@ removeServiceFromPath sty = removeProxyPath (T.pack $ serviceTypeToProxyPath sty
slideProxyServer :: Env -> FrameId -> ServerT Raw m
slideProxyServer env (FrameId frameId) =
defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) env
defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) id env
where
changePath :: ByteString -> ByteString
changePath _ = TE.encodeUtf8 $ "/p/" <> frameId <> "#/"
publishProxyServer :: Env -> FrameId -> ServerT Raw m
publishProxyServer env (FrameId frameId) =
defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) env
-- | Rather than using the publish feature of HedgeDoc / CodiMD, we rely on our
-- own URL sharing feauture.
publishProxyServer :: ProxyCache -> Env -> FrameId -> ServerT Raw m
publishProxyServer cache env frameId = Tagged $ \req res -> do
-- Lookup the cookie (indexed by frameId) which will contain the node id.
mbNodeId <- InMemory.lookup cache frameId
case mbNodeId of
Nothing -> do
forwardRaw req res
Just nodeId
-> do
-- Using a mock for now.
case Share.get_url (Just Notes) (Just nodeId) (_env_config env) (_env_settings env) of
Left _e ->
-- Invalid link, treat this as a normal proxy
forwardRaw req res
Right (ShareLink uri) ->
-- Follow the redirect
res =<< redirect' status302 [] uri
where
forwardRaw =
unTagged (defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) id env)
changePath :: ByteString -> ByteString
changePath _ = TE.encodeUtf8 $ "/s/" <> frameId
changePath _ = TE.encodeUtf8 $ "/s/" <> (_FrameId frameId)
-- Generic server forwarder
proxyPassServer :: ServiceType -> Env -> ServerT Raw m
proxyPassServer sty env = defaultForwardServer sty id env
proxyPassServer sty env = defaultForwardServer sty id id env
mkProxyDestination :: Env -> ProxyDestination
mkProxyDestination env = fromMaybe (panicTrace "Invalid URI found in the proxied Request.") $ do
......@@ -248,12 +299,35 @@ removeFromReferer pth originalRequest =
proxyUrl :: Env -> BaseUrl
proxyUrl env = mkProxyUrl (env ^. hasConfig) (env ^. env_settings . microservicesSettings)
defaultForwardServer :: ServiceType
-> (Request -> Request)
-> Env
-> ServerT Raw m
defaultForwardServer sty presendModifyRequest env =
notesForwardServer :: ProxyCache
-> FrameId
-> Maybe NodeId
-> ServiceType
-> (Request -> Request)
-> Env
-> ServerT Raw m
notesForwardServer cache frameId mbNodeId sty presendModifyRequest env =
case mbNodeId of
Nothing
-> defaultForwardServer sty presendModifyRequest id env
Just nid
-> do
-- Persist the node id in the cache
Tagged $ \req res -> do
InMemory.insert cache frameId nid
unTagged (defaultForwardServer sty presendModifyRequest (setFrameIdCookie frameId nid) env) req res
where
setFrameIdCookie :: FrameId -> NodeId -> (ResponseHeaders -> ResponseHeaders)
setFrameIdCookie (FrameId (T.unpack -> fid)) (UnsafeMkNodeId nid) origHeaders
= let sk = (hSetCookie, fromString $ fid <> "=" <> Prelude.show nid)
in sk : origHeaders
defaultForwardServerWithSettings :: ServiceType
-> (Request -> Request)
-> Env
-> WaiProxySettings
-> ServerT Raw m
defaultForwardServerWithSettings sty presendModifyRequest env proxySettings =
Tagged $ waiProxyToSettings forwardRequest (proxySettings) (env ^. env_manager)
where
......@@ -263,14 +337,6 @@ defaultForwardServer sty presendModifyRequest env =
proxyUrlStr :: String
proxyUrlStr = showBaseUrl (proxyUrl env)
proxySettings :: WaiProxySettings
proxySettings =
defaultWaiProxySettings {
wpsProcessBody = \_req _res -> Just $ replaceRelativeLinks (C8.pack $ proxyUrlStr <> serviceTypeToProxyPath sty)
, wpsModifyResponseHeaders = \_req _res -> tweakResponseHeaders
, wpsRedirectCounts = 5
}
setHost :: ProxyDestination -> RequestHeaders -> RequestHeaders
setHost hst hdrs = (hHost, fwdHost hst) : filter ((/=) hHost . fst) hdrs
......@@ -287,6 +353,27 @@ defaultForwardServer sty presendModifyRequest env =
}
pure $ WPRModifiedRequest proxiedReq (ProxyDest (fwdHost proxyDestination) (fwdPort proxyDestination))
defaultForwardServer :: ServiceType
-> (Request -> Request)
-> (ResponseHeaders -> ResponseHeaders)
-> Env
-> ServerT Raw m
defaultForwardServer sty presendModifyRequest mapRespHeaders env =
defaultForwardServerWithSettings sty presendModifyRequest env $
defaultWaiProxySettings {
wpsProcessBody = \_req _res -> Just $ replaceRelativeLinks proxyDestination proxyPath
, wpsModifyResponseHeaders = \_req _res -> (mapRespHeaders . tweakResponseHeaders)
, wpsRedirectCounts = 5
}
where
proxyPath = C8.pack $ proxyUrlStr <> serviceTypeToProxyPath sty
proxyDestination :: ProxyDestination
proxyDestination = mkProxyDestination env
proxyUrlStr :: String
proxyUrlStr = showBaseUrl (proxyUrl env)
--
-- Utility functions
--
......@@ -306,12 +393,15 @@ tweakResponseHeaders = Prelude.map tweakHeader
= (k,v)
-- | Replaces the relative links in any HTML blob returned by the proxy.
replaceRelativeLinks :: B.ByteString -> ConduitT B.ByteString (Flush Builder) IO ()
replaceRelativeLinks assetPath = CC.map flushReplace
replaceRelativeLinks :: ProxyDestination -> B.ByteString -> ConduitT B.ByteString (Flush Builder) IO ()
replaceRelativeLinks proxyTarget assetPath = CC.map flushReplace
where
-- Replaces the relative links in the proxied page content with proper urls.
flushReplace :: B.ByteString -> Flush Builder
flushReplace = Chunk . byteString . replaceIt
flushReplace = Chunk . byteString
. BL.toStrict
. BS.replace (C8.pack . showBaseUrl . _ProxyDestination $ proxyTarget) assetPath
. replaceIt
replaceIt :: B.ByteString -> B.ByteString
replaceIt htmlBlob =
......
......@@ -15,6 +15,7 @@
- "hspec-core-2.11.1"
- "hspec-discover-2.11.1"
- "hspec-expectations-0.8.3"
- "http-accept-0.2"
- "ihaskell-0.11.0.0"
- "ipython-kernel-0.11.0.0"
- "located-base-0.1.1.1"
......@@ -48,6 +49,7 @@
- "validation-selective-0.2.0.0"
- "vector-0.12.3.0"
- "wai-3.2.4"
- "wai-util-0.8"
- commit: 2b5d69448557e89002c0179ea1aaf59bb757a6e3
git: "https://github.com/AccelerateHS/accelerate-llvm.git"
subdirs:
......@@ -132,7 +134,7 @@
git: "https://gitlab.iscpif.fr/gargantext/crawlers/epo-proxy-api.git"
subdirs:
- .
- commit: 3a7d039e07c8564e8ff84ef88480924d18aa5018
- commit: 1dbd939257d33126e49d2679375553df1f2eebc5
git: "https://gitlab.iscpif.fr/gargantext/crawlers/hal.git"
subdirs:
- .
......@@ -519,6 +521,9 @@ flags:
"optimised-mixer": false
"streaming-commons":
"use-bytestring-builder": false
stringsearch:
base3: false
base4: true
tagged:
deepseq: true
transformers: true
......
......@@ -19,6 +19,6 @@ allowed-origins = [
use-origins-for-hosts = true
[microservices]
proxy-port = 8009
[microservices.proxy]
port = 8009
enabled = false
......@@ -7,29 +7,29 @@ module Test.API.Private (
tests
) where
import Gargantext.API.Routes.Named.Node
import Gargantext.API.Routes.Named.Private
import Gargantext.Core.Types (Node)
import Gargantext.Core.Types.Individu
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
import Gargantext.Prelude hiding (get)
import Network.HTTP.Client hiding (Proxy)
import Network.Wai
import Servant.Auth.Client ()
import Servant.Client
import Servant.Client.Generic (genericClient)
import Test.API.Private.Share qualified as Share
import Test.API.Routes (mkUrl)
import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
import Test.Database.Types
import Test.Hspec
import Test.Hspec.Wai hiding (pendingWith)
import Test.Hspec.Wai.Internal (withApplication)
import Test.Hspec.Wai.JSON (json)
import Test.Utils (protected, shouldRespondWithFragment, withValidLogin)
import Gargantext.API.Routes.Named.Private
import Gargantext.Core.Types (Node)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
import Servant.Client.Generic (genericClient)
import Gargantext.API.Routes.Named.Node
tests :: Spec
tests = sequential $ aroundAll withTestDBAndPort $ do
describe "Prelude" $ do
it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
privateTests :: SpecWith ((TestEnv, Int), Application)
privateTests =
describe "Private API" $ do
baseUrl <- runIO $ parseBaseUrl "http://localhost"
manager <- runIO $ newManager defaultManagerSettings
......@@ -90,3 +90,13 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
withApplication app $ do
withValidLogin port "alice" (GargPassword "alice") $ \token -> do
protected token "GET" (mkUrl port "/tree/1") "" `shouldRespondWith` 403
tests :: Spec
tests = do
sequential $ aroundAll withTestDBAndPort $ do
describe "Prelude" $ do
it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
privateTests
describe "Share API" $ do
Share.tests
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Test.API.Private.Share (
tests
) where
import Control.Lens
import Data.ByteString.Lazy.Char8 qualified as CL8
import Data.Text qualified as T
import Gargantext.API.Errors
import Gargantext.API.Routes.Named
import Gargantext.API.Routes.Named.Private
import Gargantext.API.Routes.Named.Share
import Gargantext.Core.Types
import Gargantext.Core.Types.Individu
import Gargantext.Prelude
import Network.HTTP.Client hiding (responseBody)
import Prelude (fail)
import Servant.Auth.Client qualified as SC
import Servant.Client
import Test.API.Routes
import Test.API.Setup
import Test.API.UpdateList (newCorpusForUser)
import Test.Hspec
import Test.Hspec.Wai.Internal (withApplication)
import Test.Utils
shareURL :: SC.Token -> Maybe NodeType -> Maybe NodeId -> ClientM ShareLink
shareURL token =
clientRoutes & apiWithCustomErrorScheme
& ($ GES_new)
& backendAPI
& backendAPI'
& mkBackEndAPI
& gargAPIVersion
& gargPrivateAPI
& mkPrivateAPI
& ($ token)
& shareUrlAPI
& shareUrlEp
tests :: Spec
tests = sequential $ aroundAll withTestDBAndPort $ do
describe "Prelude" $ do
it "setup DB triggers" $ \((testEnv, _), _) -> do
setupEnvironment testEnv
-- Let's create the Alice user.
createAliceAndBob testEnv
baseUrl <- runIO $ parseBaseUrl "http://localhost"
manager <- runIO $ newManager defaultManagerSettings
let clientEnv port = mkClientEnv manager (baseUrl { baseUrlPort = port })
it "should fail if no node type is specified" $ \((_testEnv, serverPort), app) -> do
withApplication app $ do
withValidLogin serverPort "alice" (GargPassword "alice") $ \token -> do
url <- liftIO $ runClientM (shareURL (toServantToken token) Nothing Nothing) (clientEnv serverPort)
case url of
Left (FailureResponse _req res)
-> liftIO $ (CL8.unpack $ responseBody res) `shouldSatisfy` (T.isInfixOf "Invalid node Type" . T.pack)
_ -> fail "Test did not fail as expected!"
it "should fail if no node ID is specified" $ \((_testEnv, serverPort), app) -> do
withApplication app $ do
withValidLogin serverPort "alice" (GargPassword "alice") $ \token -> do
url <- liftIO $ runClientM (shareURL (toServantToken token) (Just NodeCorpus) Nothing) (clientEnv serverPort)
case url of
Left (FailureResponse _req res)
-> liftIO $ (CL8.unpack $ responseBody res) `shouldSatisfy` (T.isInfixOf "Invalid node ID" . T.pack)
_ -> fail "Test did not fail as expected!"
it "should return a valid URL" $ \((testEnv, serverPort), app) -> do
withApplication app $ do
withValidLogin serverPort "alice" (GargPassword "alice") $ \token -> do
cId <- liftIO $ newCorpusForUser testEnv "alice"
url <- liftIO $ runClientM (shareURL (toServantToken token) (Just NodeCorpus) (Just cId)) (clientEnv serverPort)
case url of
Left err
-> fail (show err)
Right (ShareLink _)
-> pure ()
it "should include the port if needed (like localhost)" $ \((testEnv, serverPort), app) -> do
withApplication app $ do
withValidLogin serverPort "alice" (GargPassword "alice") $ \token -> do
cId <- liftIO $ newCorpusForUser testEnv "alice"
url <- liftIO $ runClientM (shareURL (toServantToken token) (Just NodeCorpus) (Just cId)) (clientEnv serverPort)
case url of
Left err
-> fail (show err)
Right (ShareLink uri)
-> liftIO $ "localhost:80" `T.isInfixOf` T.pack (show uri) `shouldBe` True
......@@ -7,6 +7,8 @@ import Control.Concurrent.Async qualified as Async
import Control.Concurrent.MVar
import Control.Lens
import Control.Monad.Reader
import Data.Cache qualified as InMemory
import Data.Streaming.Network (bindPortTCP)
import Gargantext.API (makeApp)
import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..))
import Gargantext.API.Admin.Settings
......@@ -47,8 +49,7 @@ import Servant.Client
import Servant.Job.Async qualified as ServantAsync
import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo, fakeSettingsPath)
import Test.Database.Types
import qualified UnliftIO
import Data.Streaming.Network (bindPortTCP)
import UnliftIO qualified
newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port -> IO Env
......@@ -137,9 +138,10 @@ withBackendServerAndProxy action =
gargApp <- withLoggerHoisted Mock $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080
makeApp env
proxyCache <- InMemory.newCache Nothing
proxyApp <- withLoggerHoisted Mock $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080
pure $ microServicesProxyApp env
pure $ microServicesProxyApp proxyCache env
Warp.testWithApplication (pure gargApp) $ \serverPort ->
testWithApplicationOnPort (pure proxyApp) proxyPort $
......
module Test.Core.Text.Corpus.TSV (tests) where
import Gargantext.Core.Text.Corpus.Parsers.TSV
import Test.QuickCheck
import Test.QuickCheck.Instances ()
import Data.ByteString.Lazy.UTF8 as BLU
import Data.ByteString.Lazy as BL
import Data.Char ( ord )
import Data.Text as DT (Text, pack, null, elem)
import Data.Text.Encoding as DT
import Prelude
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck hiding (Positive, Negative)
tests :: TestTree
tests = testGroup "TSV Parser" [
testProperty "Parses 'Valid Text'" testValidText
, testProperty "Parses 'Valid Number'" testValidNumber
, testProperty "Parses 'Error Per Line On A File'" testTestErrorPerLine
, testProperty "Parses 'Correct File'" testTestCorrectFile
, testProperty "Parses 'Correct File With New Line In Last Header'" testTestCorrectFileWithNewLine
, testProperty "Parses 'Find Delimiter'" testFindDelimiter
, testProperty "Parses 'Get Headers'" testGetHeader]
delimiterBS :: Delimiter -> BL.ByteString
delimiterBS Tab = BLU.fromString "\t"
delimiterBS Comma = BLU.fromString ","
delimiterBS Line = BLU.fromString "\n"
data File = File { fDelimiter :: Delimiter
, allCorpus :: [RandomCorpus]
}
deriving (Show)
data RandomCorpus =
RandomCorpus { abstract :: Text
, title :: Text
, authors :: Text
, source :: Text
, day :: Int
, month :: Int
, years :: Int
}
deriving (Show)
instance Arbitrary File where
arbitrary = sized arbitrarySizedFile
arbitrarySizedFile :: Int -> Gen File
arbitrarySizedFile m = do
del <- elements [Tab, Comma]
corp <- vectorOf m (generateRandomCorpus)
return (File del corp)
delimiterToText :: Delimiter -> Text
delimiterToText Tab = DT.pack "\t"
delimiterToText Comma = DT.pack ","
delimiterToText Line = DT.pack "\n"
delimiterToString :: Delimiter -> Char
delimiterToString Tab = '\t'
delimiterToString Comma = ','
delimiterToString Line = '\n'
textToBL :: Text -> BL.ByteString
textToBL b = BL.fromChunks . return . DT.encodeUtf8 $ b
generateRandomCorpus :: Gen RandomCorpus
generateRandomCorpus = RandomCorpus
<$> generateString
<*> generateString
<*> generateString
<*> generateString
<*> generateNumber
<*> generateNumber
<*> generateNumber
generateFileDelimiter :: Gen File
generateFileDelimiter = do
del <- elements [Tab, Comma]
m <- choose (1,5)
corp <- vectorOf m (generateRandomCorpus)
return (File del corp)
generateFile :: Gen File
generateFile = arbitrary :: Gen File
generateString :: Gen Text
generateString = arbitrary :: Gen Text
generateNumber :: Gen Int
generateNumber = arbitrary :: Gen Int
randomHeaderList :: Gen [String]
randomHeaderList = frequency [
(1, return [])
, (7, (:) <$> (elements ["Publication Day", "Publication Month", "Publication Year", "Authors", "Title", "Source", "Abstract"]) <*> randomHeaderList)
]
--TODO add delimiter
createLineFromCorpus :: RandomCorpus -> Delimiter -> BL.ByteString
createLineFromCorpus corpus delD = do
let aut = (DT.pack "\"") <> (authors corpus) <> (DT.pack "\"")
let tit = (DT.pack "\"") <> (title corpus) <> (DT.pack "\"")
let sou = (DT.pack "\"") <> (source corpus) <> (DT.pack "\"")
let abt = (DT.pack "\"") <> (abstract corpus) <> (DT.pack "\"")
let pDay = (DT.pack "\"") <> (DT.pack $ show $ day corpus) <> (DT.pack "\"")
let pMonth = (DT.pack "\"") <> (DT.pack $ show $ month corpus) <> (DT.pack "\"")
let pYears = (DT.pack "\"") <> (DT.pack $ show $ years corpus) <> (DT.pack "\"")
let del = delimiterToText delD
textToBL(pDay <> del <> pMonth <> del <> pYears <> del <> aut <> del <> tit <> del <> sou <> del <> abt)
createLineFromCorpusWithNewLine :: RandomCorpus -> Delimiter -> BL.ByteString
createLineFromCorpusWithNewLine corpus delD = do
let aut = (DT.pack "\"") <> (authors corpus) <> (DT.pack "\"")
let tit = (DT.pack "\"") <> (title corpus) <> (DT.pack "\"")
let sou = (DT.pack "\"") <> (source corpus) <> (DT.pack "\"")
let abt = (DT.pack "\"") <> (abstract corpus) <> (DT.pack "\n") <> (abstract corpus) <> (DT.pack "\"")
let pDay = (DT.pack "\"") <> (DT.pack $ show $ day corpus) <> (DT.pack "\"")
let pMonth = (DT.pack "\"") <> (DT.pack $ show $ month corpus) <> (DT.pack "\"")
let pYears = (DT.pack "\"") <> (DT.pack $ show $ years corpus) <> (DT.pack "\"")
let del = delimiterToText delD
textToBL(pDay <> del <> pMonth <> del <> pYears <> del <> aut <> del <> tit <> del <> sou <> del <> abt)
createFile :: File -> BL.ByteString
createFile file = do
let headers = BL.intercalate (delimiterBS (fDelimiter file)) $ Prelude.map BLU.fromString ["Publication Day", "Publication Month", "Publication Year", "Authors", "Title", "Source", "Abstract"]
let allLines = BL.intercalate (BLU.fromString "\n") $ Prelude.map (\x -> createLineFromCorpusWithNewLine x (fDelimiter file)) (allCorpus file)
headers <> (BLU.fromString "\n") <> allLines
createFileWithNewLine :: File -> BL.ByteString
createFileWithNewLine file = do
let headers = BL.intercalate (delimiterBS (fDelimiter file)) $ Prelude.map BLU.fromString ["Publication Day", "Publication Month", "Publication Year", "Authors", "Title", "Source", "Abstract"]
let allLines = BL.intercalate (BLU.fromString "\n") $ Prelude.map (\x -> createLineFromCorpus x (fDelimiter file)) (allCorpus file)
headers <> (BLU.fromString "\n") <> allLines
validRandomCorpus :: RandomCorpus -> Delimiter -> Bool
validRandomCorpus tsv del
| BL.length (BL.filter (==delimiter del) (createLineFromCorpus tsv del)) > 3= True
| DT.null $ abstract tsv = True
| DT.null $ title tsv = True
| DT.null $ authors tsv = True
| DT.null $ source tsv = True
| DT.elem '\"' (abstract tsv ) = True
| DT.elem '\"' (title tsv) = True
| DT.elem '\"' (authors tsv) = True
| DT.elem '\"' (source tsv) = True
| otherwise = False
-- Test the 'validTextField' function (test if a field is good on garganText)
testValidNumber :: Property
testValidNumber = forAll generateNumber (\s -> do
let nbText = DT.pack $ show s
let bl = textToBL nbText
case validNumber bl nbText 1 of
Right _ -> True
Left _ | BL.empty == bl -> True
| s < 1 -> True
| otherwise -> False)
-- Test the 'validTextField' function (test if a field is good on garganText)
testValidText :: Property
testValidText = forAll generateString (\s ->
let bl = textToBL s in
case validTextField bl s 1 of
Right _ -> True
Left _ | BL.empty == bl -> True
| (fromIntegral $ ord '\"') `BL.elem` bl -> True
| otherwise -> False)
-- Test if a single line id OK
testTestErrorPerLine :: Property
testTestErrorPerLine = forAll generateRandomCorpus (\tsv -> do
let del = Tab
let line = createLineFromCorpus tsv del
let headers = Prelude.map DT.pack ["Publication Day", "Publication Month", "Publication Year", "Authors", "Title", "Source", "Abstract"]
let splitLine = BL.splitWith (==delimiter del) line
case testErrorPerLine splitLine del headers 1 of
Right _ -> True
Left _ -> validRandomCorpus tsv del)
--check :
-- True Del
-- False Error
-- Test if a file is OK
testTestCorrectFile :: Property
testTestCorrectFile = forAll generateFile (\file -> do
let tsv = createFile file
case testCorrectFile tsv of
Right del -> del == fDelimiter file
Left _ -> Prelude.all (\x -> do
let del = fDelimiter file
let headers = Prelude.map DT.pack ["Publication Day", "Publication Month", "Publication Year", "Authors", "Title", "Source", "Abstract"]
let splitLine = BL.splitWith (==delimiter del) $ createLineFromCorpus x del
case testErrorPerLine splitLine del headers 1 of
Right _ -> True
Left _ -> validRandomCorpus x del) (allCorpus file))
-- almost the same as the one above but also test if a corpus with abstract of multiple line is OK
testTestCorrectFileWithNewLine :: Property
testTestCorrectFileWithNewLine = forAll generateFile (\file -> do
let tsv = createFileWithNewLine file
case testCorrectFile tsv of
Right _ -> True
Left _ -> Prelude.all (\x -> do
let del = fDelimiter file
let headers = Prelude.map DT.pack ["Publication Day", "Publication Month", "Publication Year", "Authors", "Title", "Source", "Abstract"]
let splitLine = BL.splitWith (==delimiter del) $ createLineFromCorpus x del
case testErrorPerLine splitLine del headers 1 of
Right _ -> True
Left _ -> validRandomCorpus x del) (allCorpus file))
testFindDelimiter :: Property
testFindDelimiter = forAll generateFileDelimiter (\file -> do
let tsv = createFile file
case findDelimiter tsv of
Right _ -> True
Left _ -> do
let line = Prelude.head $ allCorpus file
let del = delimiterToString $ fDelimiter file
let delLine = delimiterToString Line
del `DT.elem` (abstract line) || del `DT.elem` (authors line) || del `DT.elem` (title line) || del `DT.elem` (source line) || delLine `DT.elem` (abstract line) || delLine `DT.elem` (authors line) || delLine `DT.elem` (title line) || delLine `DT.elem` (source line))
testGetHeader :: Property
testGetHeader = forAll randomHeaderList (\headers -> do
let headersLines = (BL.intercalate (delimiterBS Tab) $ Prelude.map BLU.fromString headers):[]
case getHeaders headersLines Tab of
Right _ -> True
Left _ | not ("Publication Day" `Prelude.elem` headers) -> True
| not ("Publication Month" `Prelude.elem` headers) -> True
| not ("Publication Year" `Prelude.elem` headers) -> True
| not ("Authors" `Prelude.elem` headers) -> True
| not ("Source" `Prelude.elem` headers) -> True
| not ("Title" `Prelude.elem` headers) -> True
| not ("Abstract" `Prelude.elem` headers) -> True
| otherwise -> False
)
\ No newline at end of file
......@@ -38,6 +38,7 @@ writeFrameTests = sequential $ aroundAll withBackendServerAndProxy $ do
& ($ (Token "bogus"))
& notesEp
& ($ (FrameId "abcdef"))
& ($ Nothing)
& ($ "GET")
) (clientEnv proxyPort)
......@@ -66,6 +67,7 @@ writeFrameTests = sequential $ aroundAll withBackendServerAndProxy $ do
& ($ (toServantToken $ autRes ^. authRes_token))
& notesEp
& ($ (FrameId "abcdef"))
& ($ Nothing)
& ($ "GET")
) (clientEnv proxyPort)
......
......@@ -13,6 +13,7 @@ module Main where
import Gargantext.Prelude
import qualified Test.Core.Text.Corpus.Query as CorpusQuery
import qualified Test.Core.Text.Corpus.TSV as TSVParser
import qualified Test.Core.Utils as Utils
import qualified Test.Graph.Clustering as Graph
import qualified Test.Ngrams.NLP as NLP
......@@ -50,6 +51,7 @@ main = do
, jobsSpec
, NgramsQuery.tests
, CorpusQuery.tests
, TSVParser.tests
, JSON.tests
, Errors.tests
, similaritySpec
......
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