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 ## Version 0.0.7.1.9
* [BACK][FIX][Write Frame microservice proxy improvements (#364)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/364) * [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: ...@@ -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. Clone both the backend (`haskell-gargantext`), and the frontend (`purescript-gargantext`) at the root of the backend.
```shell ```shell
git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git $ git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
cd haskell-gargantext $ cd haskell-gargantext
git clone https://gitlab.iscpif.fr/gargantext/purescript-gargantext.git $ git clone https://gitlab.iscpif.fr/gargantext/purescript-gargantext.git
cd .. $ 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 ```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`. At any point, you can exit a Nix shell and go back to your regular shell by running `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*.
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 ```shell
nix-shell --run "my command" $ nix-shell --run "my command"
``` ```
is equivalent to running `my command` from within a Nix shell. 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 ```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.* *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`.* *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 ```shell
n$ cabal update n$ cabal update
n$ cabal install 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 ```shell
./bin/install n$ cabal run gargantext-server -- --ini gargantext.ini --run Prod
cd purescript-gargantext/
./bin/install
cd ..
``` ```
### Initializing and running ### Initializing and running
...@@ -96,8 +126,8 @@ cd .. ...@@ -96,8 +126,8 @@ cd ..
#### Start containers for database and NLP software bricks #### Start containers for database and NLP software bricks
```shell ```shell
cd devops/docker $ cd devops/docker
docker compose up $ docker compose up
``` ```
The initialization schema should be loaded automatically from `devops/postgres/schema.sql`. 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 ...@@ -105,7 +135,7 @@ The initialization schema should be loaded automatically from `devops/postgres/s
#### Create configuration file #### Create configuration file
```shell ```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. > `.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 ...@@ -121,24 +151,25 @@ The master user's name is automatically set to `gargantua`, but you will be prom
#### Running #### 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 ```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 ### Running tests
From nix shell: From nix shell:
``` ```shell
cabal v2-test --test-show-details=streaming n$ cabal v2-test --test-show-details=streaming
``` ```
Or, from "outside": Or, from "outside":
``` ```shell
nix-shell --run "cabal v2-test --test-show-details=streaming" $ nix-shell --run "cabal v2-test --test-show-details=streaming"
``` ```
### Working on libraries ### Working on libraries
...@@ -157,12 +188,19 @@ When a devlopment is needed on libraries (for instance, the HAL crawler in https ...@@ -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. > 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> ## Use Cases <a name="use-cases"></a>
### Multi-User with Graphical User Interface (Server Mode) ### Multi-User with Graphical User Interface (Server Mode)
``` sh ``` shell
~/.local/bin/stack --docker exec gargantext-server -- --ini "gargantext.ini" --run Prod $ ~/.local/bin/stack --docker exec gargantext-server -- --ini "gargantext.ini" --run Prod
``` ```
Then you can log in with `user1` / `1resu` Then you can log in with `user1` / `1resu`
...@@ -172,23 +210,23 @@ 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 #### Simple cooccurrences computation and indexation from a list of Ngrams
``` sh ``` shell
stack --docker exec gargantext-cli -- CorpusFromGarg.csv ListFromGarg.csv Ouput.json $ stack --docker exec gargantext-cli -- CorpusFromGarg.csv ListFromGarg.csv Ouput.json
``` ```
### Analyzing the ngrams table repo ### 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: 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 ``` shell
cat repos/repo.cbor.v5 | stack exec gargantext-cbor2json | jq . $ cat repos/repo.cbor.v5 | stack exec gargantext-cbor2json | jq .
``` ```
### Documentation ### Documentation
To build documentation, run: To build documentation, run:
```sh ```shell
stack build --haddock --no-haddock-deps --fast $ stack build --haddock --no-haddock-deps --fast
``` ```
(in `.stack-work/dist/x86_64-linux-nix/Cabal-3.2.1.0/doc/html/gargantext`). (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 ...@@ -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/ 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: To upgrade PostgreSQL in Docker containers, for example from 11.x to 14.x, simply run:
```sh ```shell
docker exec -it <container-id> pg_dumpall -U gargantua > 11-db.dump $ 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: 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 ```shell
docker-compose rm postgres $ docker-compose rm postgres
docker volume rm docker_garg-pgdata $ docker volume rm docker_garg-pgdata
``` ```
Now, start the container and execute: Now, start the container and execute:
```sh ```shell
# need to drop the empty DB first, since schema will be created when restoring the dump $ # 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 $ docker exec -i <new-container-id> dropdb -U gargantua gargandbV5
# recreate the db, but empty with no schema $ # recreate the db, but empty with no schema
docker exec -i <new-container-id> createdb -U gargantua gargandbV5 $ docker exec -i <new-container-id> createdb -U gargantua gargandbV5
# now we can restore the dump $ # now we can restore the dump
docker exec -i <new-container-id> psql -U gargantua -d gargandbV5 < 11-db.dump $ docker exec -i <new-container-id> psql -U gargantua -d gargandbV5 < 11-db.dump
``` ```
### Upgrading using ### Upgrading using
...@@ -258,25 +296,25 @@ docker exec -i <new-container-id> psql -U gargantua -d gargandbV5 < 11-db.dump ...@@ -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. 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: First save your data:
``` ```shell
sudo su postgres $ sudo su postgres
pg_dumpall > gargandb.dump $ pg_dumpall > gargandb.dump
``` ```
Upgrade postgresql: Upgrade postgresql:
``` ```shell
sudo apt install postgresql-server-14 postgresql-client-14 $ sudo apt install postgresql-server-14 postgresql-client-14
sudo apt remove --purge postgresql-13 $ sudo apt remove --purge postgresql-13
``` ```
Restore your data: Restore your data:
``` ```shell
sudo su postgres $ sudo su postgres
psql < gargandb.dump $ psql < gargandb.dump
``` ```
Maybe you need to restore the gargantua password Maybe you need to restore the gargantua password
``` ```shell
ALTER ROLE gargantua PASSWORD 'yourPasswordIn_gargantext.ini' $ ALTER ROLE gargantua PASSWORD 'yourPasswordIn_gargantext.ini'
``` ```
Maybe you need to change the port to 5433 for database connection in your gargantext.ini file. Maybe you need to change the port to 5433 for database connection in your gargantext.ini file.
......
...@@ -18,6 +18,7 @@ import Options.Applicative ...@@ -18,6 +18,7 @@ import Options.Applicative
import Prelude import Prelude
import Servant.API import Servant.API
import Servant.API.Routes import Servant.API.Routes
import Servant.API.WebSocket qualified as WS (WebSocketPending)
import Servant.Auth qualified as Servant import Servant.Auth qualified as Servant
routesCmd :: Mod CommandFields CLI routesCmd :: Mod CommandFields CLI
...@@ -42,6 +43,9 @@ export_p = CLIR_export <$> ...@@ -42,6 +43,9 @@ export_p = CLIR_export <$>
instance HasRoutes api => HasRoutes (Servant.Auth xs a :> api) where instance HasRoutes api => HasRoutes (Servant.Auth xs a :> api) where
getRoutes = getRoutes @api getRoutes = getRoutes @api
instance HasRoutes WS.WebSocketPending where
getRoutes = []
instance HasRoutes Raw where instance HasRoutes Raw where
getRoutes = [] getRoutes = []
......
...@@ -93,7 +93,7 @@ source-repository-package ...@@ -93,7 +93,7 @@ source-repository-package
source-repository-package source-repository-package
type: git type: git
location: https://gitlab.iscpif.fr/gargantext/crawlers/hal.git location: https://gitlab.iscpif.fr/gargantext/crawlers/hal.git
tag: 3a7d039e07c8564e8ff84ef88480924d18aa5018 tag: 1dbd939257d33126e49d2679375553df1f2eebc5
source-repository-package source-repository-package
type: git type: git
......
...@@ -93,6 +93,7 @@ constraints: any.Cabal ==3.8.1.0, ...@@ -93,6 +93,7 @@ constraints: any.Cabal ==3.8.1.0,
any.c2hs ==0.28.8, any.c2hs ==0.28.8,
c2hs +base3 -regression, c2hs +base3 -regression,
any.cabal-doctest ==1.0.9, any.cabal-doctest ==1.0.9,
any.cache ==0.1.3.0,
any.call-stack ==0.4.0, any.call-stack ==0.4.0,
any.case-insensitive ==1.2.1.0, any.case-insensitive ==1.2.1.0,
any.cassava ==0.5.3.0, any.cassava ==0.5.3.0,
...@@ -277,6 +278,7 @@ constraints: any.Cabal ==3.8.1.0, ...@@ -277,6 +278,7 @@ constraints: any.Cabal ==3.8.1.0,
any.hspec-wai ==0.11.1, any.hspec-wai ==0.11.1,
any.hspec-wai-json ==0.11.0, any.hspec-wai-json ==0.11.0,
any.hstatistics ==0.3.1, any.hstatistics ==0.3.1,
any.http-accept ==0.2,
any.http-api-data ==0.5, any.http-api-data ==0.5,
http-api-data -use-text-show, http-api-data -use-text-show,
any.http-client ==0.7.14, any.http-client ==0.7.14,
...@@ -555,6 +557,8 @@ constraints: any.Cabal ==3.8.1.0, ...@@ -555,6 +557,8 @@ constraints: any.Cabal ==3.8.1.0,
streaming-commons -use-bytestring-builder, streaming-commons -use-bytestring-builder,
any.strict ==0.5, any.strict ==0.5,
any.string-conversions ==0.4.0.1, any.string-conversions ==0.4.0.1,
any.stringsearch ==0.3.6.6,
stringsearch -base3 +base4,
any.swagger2 ==2.8.7, any.swagger2 ==2.8.7,
any.syb ==0.7.2.4, any.syb ==0.7.2.4,
any.system-cxx-std-lib ==1.0, any.system-cxx-std-lib ==1.0,
...@@ -664,6 +668,7 @@ constraints: any.Cabal ==3.8.1.0, ...@@ -664,6 +668,7 @@ constraints: any.Cabal ==3.8.1.0,
any.wai-extra ==3.1.13.0, any.wai-extra ==3.1.13.0,
wai-extra -build-example, wai-extra -build-example,
any.wai-logger ==2.4.0, any.wai-logger ==2.4.0,
any.wai-util ==0.8,
any.wai-websockets ==3.0.1.2, any.wai-websockets ==3.0.1.2,
wai-websockets +example, wai-websockets +example,
any.warp ==3.3.25, 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 = [ ...@@ -16,10 +16,11 @@ allowed-origins = [
, "https://dev.sub.gargantext.org" , "https://dev.sub.gargantext.org"
, "http://localhost:8008" , "http://localhost:8008"
, "http://localhost:8108" , "http://localhost:8108"
, "http://localhost:3000"
] ]
use-origins-for-hosts = true use-origins-for-hosts = true
[microservices] [microservices.proxy]
port = 8009
proxy-port = 8009 enabled = false
...@@ -5,7 +5,7 @@ cabal-version: 3.4 ...@@ -5,7 +5,7 @@ cabal-version: 3.4
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
name: gargantext name: gargantext
version: 0.0.7.1.9 version: 0.0.7.1.14
synopsis: Search, map, share synopsis: Search, map, share
description: Please see README.md description: Please see README.md
category: Data category: Data
...@@ -530,10 +530,12 @@ library ...@@ -530,10 +530,12 @@ library
, blaze-svg ^>= 0.3.6.1 , blaze-svg ^>= 0.3.6.1
, boolexpr ^>= 0.2 , boolexpr ^>= 0.2
, bytestring ^>= 0.10.12.0 , bytestring ^>= 0.10.12.0
, cache >= 0.1.3.0
, case-insensitive ^>= 1.2.1.0 , case-insensitive ^>= 1.2.1.0
, cassava ^>= 0.5.2.0 , cassava ^>= 0.5.2.0
, cborg ^>= 0.2.6.0 , cborg ^>= 0.2.6.0
, cereal ^>= 0.5.8.2 , cereal ^>= 0.5.8.2
, clock >= 0.8
, conduit ^>= 1.3.4.2 , conduit ^>= 1.3.4.2
, conduit-extra ^>= 1.3.5 , conduit-extra ^>= 1.3.5
, containers ^>= 0.6.5.1 , containers ^>= 0.6.5.1
...@@ -676,6 +678,7 @@ library ...@@ -676,6 +678,7 @@ library
, stemmer ^>= 0.5.2 , stemmer ^>= 0.5.2
, stm ^>= 2.5.0.1 , stm ^>= 2.5.0.1
, stm-containers >= 1.2.1 && < 1.3 , stm-containers >= 1.2.1 && < 1.3
, stringsearch >= 0.3.6.6
, swagger2 ^>= 2.6 , swagger2 ^>= 2.6
, taggy-lens ^>= 0.1.2 , taggy-lens ^>= 0.1.2
, tagsoup ^>= 0.14.8 , tagsoup ^>= 0.14.8
...@@ -703,6 +706,7 @@ library ...@@ -703,6 +706,7 @@ library
, wai-app-static ^>= 3.1.7.3 , wai-app-static ^>= 3.1.7.3
, wai-cors ^>= 0.2.7 , wai-cors ^>= 0.2.7
, wai-extra ^>= 3.1.8 , wai-extra ^>= 3.1.8
, wai-util >= 0.8
, wai-websockets ^>= 3.0.1.2 , wai-websockets ^>= 3.0.1.2
, warp ^>= 3.3.20 , warp ^>= 3.3.20
, websockets ^>= 0.12.7.3 , websockets ^>= 0.12.7.3
...@@ -761,6 +765,7 @@ executable gargantext-cli ...@@ -761,6 +765,7 @@ executable gargantext-cli
, servant , servant
, servant-auth , servant-auth
, servant-routes < 0.2 , servant-routes < 0.2
, servant-websockets >= 2.0.0 && < 2.1
, shelly , shelly
, split ^>= 0.2.3.4 , split ^>= 0.2.3.4
, text ^>= 1.2.4.1 , text ^>= 1.2.4.1
...@@ -813,9 +818,90 @@ executable gargantext-central-exchange ...@@ -813,9 +818,90 @@ executable gargantext-central-exchange
, unordered-containers ^>= 0.2.16.0 , unordered-containers ^>= 0.2.16.0
, vector ^>= 0.7.3 , 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 test-suite garg-test-tasty
import: import:
defaults defaults
, testDependencies
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: drivers/tasty/Main.hs main-is: drivers/tasty/Main.hs
other-modules: other-modules:
...@@ -826,6 +912,7 @@ test-suite garg-test-tasty ...@@ -826,6 +912,7 @@ test-suite garg-test-tasty
Test.Core.Similarity Test.Core.Similarity
Test.Core.Text Test.Core.Text
Test.Core.Text.Corpus.Query Test.Core.Text.Corpus.Query
Test.Core.Text.Corpus.TSV
Test.Core.Text.Examples Test.Core.Text.Examples
Test.Core.Text.Flow Test.Core.Text.Flow
Test.Core.Utils Test.Core.Utils
...@@ -904,8 +991,7 @@ test-suite garg-test-tasty ...@@ -904,8 +991,7 @@ test-suite garg-test-tasty
, raw-strings-qq , raw-strings-qq
, recover-rtti >= 0.4 && < 0.5 , recover-rtti >= 0.4 && < 0.5
, resource-pool >= 0.2.3.2 && < 0.2.4 , 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 , servant-auth
, servant-auth-client , servant-auth-client
, servant-client , servant-client
...@@ -939,7 +1025,8 @@ test-suite garg-test-tasty ...@@ -939,7 +1025,8 @@ test-suite garg-test-tasty
test-suite garg-test-hspec test-suite garg-test-hspec
import: import:
defaults defaults
, testDependencies
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: drivers/hspec/Main.hs main-is: drivers/hspec/Main.hs
other-modules: other-modules:
...@@ -950,6 +1037,7 @@ test-suite garg-test-hspec ...@@ -950,6 +1037,7 @@ test-suite garg-test-hspec
Test.API.GraphQL Test.API.GraphQL
Test.API.Notifications Test.API.Notifications
Test.API.Private Test.API.Private
Test.API.Private.Share
Test.API.Routes Test.API.Routes
Test.API.Setup Test.API.Setup
Test.API.UpdateList Test.API.UpdateList
...@@ -1003,7 +1091,7 @@ test-suite garg-test-hspec ...@@ -1003,7 +1091,7 @@ test-suite garg-test-hspec
, raw-strings-qq , raw-strings-qq
, recover-rtti >= 0.4 && < 0.5 , recover-rtti >= 0.4 && < 0.5
, resource-pool >= 0.2.3.2 && < 0.2.4 , 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
, servant-auth-client , servant-auth-client
, servant-client , servant-client
......
...@@ -37,7 +37,9 @@ module Gargantext.API ...@@ -37,7 +37,9 @@ module Gargantext.API
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Async qualified as Async import Control.Concurrent.Async qualified as Async
import Control.Lens hiding (Level) import Control.Lens hiding (Level)
import Data.Cache qualified as InMemory
import Data.List (lookup) import Data.List (lookup)
import Data.Set qualified as Set
import Data.Text (pack) import Data.Text (pack)
import Data.Text.Encoding qualified as TE import Data.Text.Encoding qualified as TE
import Data.Text.IO (putStrLn) import Data.Text.IO (putStrLn)
...@@ -65,6 +67,8 @@ import Network.Wai.Middleware.Cors ...@@ -65,6 +67,8 @@ import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.RequestLogger
-- import Paths_gargantext (getDataDir) -- import Paths_gargantext (getDataDir)
import Servant hiding (Header) 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.Cron.Schedule qualified as Cron
-- import System.FilePath -- import System.FilePath
...@@ -80,7 +84,8 @@ startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logge ...@@ -80,7 +84,8 @@ startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logge
periodicActions <- schedulePeriodicActions env periodicActions <- schedulePeriodicActions env
let runServer = run port (mid app) `finally` stopGargantext periodicActions 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 Async.race_ runServer runProxy
...@@ -92,6 +97,7 @@ startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logge ...@@ -92,6 +97,7 @@ startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logge
_ -> panicTrace $ _ -> panicTrace $
"You must run 'gargantext-init " <> pack (_IniFile iniFile) <> "You must run 'gargantext-init " <> pack (_IniFile iniFile) <>
"' before running gargantext-server (only the first time)." "' before running gargantext-server (only the first time)."
oneHour = Clock.fromNanoSecs 3600_000_000_000
portRouteInfo :: PortNumber -> PortNumber -> IO () portRouteInfo :: PortNumber -> PortNumber -> IO ()
portRouteInfo mainPort proxyPort = do portRouteInfo mainPort proxyPort = do
...@@ -158,7 +164,7 @@ makeGargMiddleware :: CORSSettings -> Mode -> IO Middleware ...@@ -158,7 +164,7 @@ makeGargMiddleware :: CORSSettings -> Mode -> IO Middleware
makeGargMiddleware crsSettings mode = do makeGargMiddleware crsSettings mode = do
let corsMiddleware = cors $ \_incomingRq -> Just let corsMiddleware = cors $ \_incomingRq -> Just
simpleCorsResourcePolicy simpleCorsResourcePolicy
{ corsOrigins = Just (map mkCorsOrigin (crsSettings ^. corsAllowedOrigins), True) { corsOrigins = Just $ (Set.toList $ Set.fromList $ map mkCorsOrigin (crsSettings ^. corsAllowedOrigins), True)
, corsMethods = [ methodGet , methodPost , methodPut , corsMethods = [ methodGet , methodPost , methodPut
, methodDelete, methodOptions, methodHead] , methodDelete, methodOptions, methodHead]
, corsIgnoreFailures = False , corsIgnoreFailures = False
...@@ -172,7 +178,7 @@ makeGargMiddleware crsSettings mode = do ...@@ -172,7 +178,7 @@ makeGargMiddleware crsSettings mode = do
pure $ loggerMiddleware . corsMiddleware pure $ loggerMiddleware . corsMiddleware
where where
mkCorsOrigin :: CORSOrigin -> Origin mkCorsOrigin :: CORSOrigin -> Origin
mkCorsOrigin = TE.encodeUtf8 . _CORSOrigin mkCorsOrigin (CORSOrigin u) = TE.encodeUtf8 . pack . showBaseUrl $ u
--------------------------------------------------------------------- ---------------------------------------------------------------------
-- | API Global -- | API Global
......
...@@ -2,6 +2,7 @@ ...@@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Gargantext.API.Admin.Settings.CORS where module Gargantext.API.Admin.Settings.CORS where
import Prelude import Prelude
...@@ -10,10 +11,11 @@ import Control.Arrow ...@@ -10,10 +11,11 @@ import Control.Arrow
import Data.Text qualified as T import Data.Text qualified as T
import Toml import Toml
import Control.Lens hiding (iso, (.=)) import Control.Lens hiding (iso, (.=))
import Data.String (IsString) import Servant.Client.Core
import Data.Maybe (fromMaybe)
newtype CORSOrigin = CORSOrigin { _CORSOrigin :: T.Text } newtype CORSOrigin = CORSOrigin { _CORSOrigin :: BaseUrl }
deriving (Show, Eq, IsString) deriving (Show, Eq)
data CORSSettings = data CORSSettings =
CORSSettings { CORSSettings {
...@@ -30,7 +32,8 @@ corsOriginCodec :: TomlBiMap CORSOrigin AnyValue ...@@ -30,7 +32,8 @@ corsOriginCodec :: TomlBiMap CORSOrigin AnyValue
corsOriginCodec = _Orig >>> _Text corsOriginCodec = _Orig >>> _Text
where where
_Orig :: BiMap e CORSOrigin T.Text _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 :: TomlCodec CORSSettings
corsSettingsCodec = CORSSettings corsSettingsCodec = CORSSettings
......
...@@ -13,12 +13,14 @@ import Toml ...@@ -13,12 +13,14 @@ import Toml
data MicroServicesSettings = data MicroServicesSettings =
MicroServicesSettings { MicroServicesSettings {
-- | The port where the microservices proxy will be listening on. -- | The port where the microservices proxy will be listening on.
_msProxyPort :: Int _msProxyPort :: !Int
, _msProxyEnabled :: !Bool
} deriving (Show, Eq) } deriving (Show, Eq)
microServicesSettingsCodec :: TomlCodec MicroServicesSettings microServicesSettingsCodec :: TomlCodec MicroServicesSettings
microServicesSettingsCodec = MicroServicesSettings microServicesSettingsCodec = MicroServicesSettings
<$> Toml.int "proxy-port" .= _msProxyPort <$> Toml.int "port" .= _msProxyPort
<*> Toml.bool "enabled" .= _msProxyEnabled
mkProxyUrl :: GargConfig -> MicroServicesSettings -> BaseUrl mkProxyUrl :: GargConfig -> MicroServicesSettings -> BaseUrl
mkProxyUrl GargConfig{..} MicroServicesSettings{..} = mkProxyUrl GargConfig{..} MicroServicesSettings{..} =
......
...@@ -22,7 +22,7 @@ makeLenses ''GargTomlSettings ...@@ -22,7 +22,7 @@ makeLenses ''GargTomlSettings
settingsCodec :: TomlCodec GargTomlSettings settingsCodec :: TomlCodec GargTomlSettings
settingsCodec = GargTomlSettings settingsCodec = GargTomlSettings
<$> (Toml.table corsSettingsCodec "cors" .= _gargCorsSettings) <$> (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 -- | Extends the 'allowed-origins' in the CORSettings with the URLs embellished
-- with the proxy port. -- with the proxy port.
...@@ -33,9 +33,7 @@ addProxyToAllowedOrigins stgs = ...@@ -33,9 +33,7 @@ addProxyToAllowedOrigins stgs =
addProxies :: Int -> CORSSettings -> CORSSettings addProxies :: Int -> CORSSettings -> CORSSettings
addProxies port cors = addProxies port cors =
let origins = _corsAllowedOrigins cors let origins = _corsAllowedOrigins cors
mkUrl (CORSOrigin u) = case parseBaseUrl (T.unpack u) of mkUrl (CORSOrigin bh) = CORSOrigin $ bh { baseUrlPort = port }
Nothing -> CORSOrigin u
Just bh -> CORSOrigin $ T.pack $ showBaseUrl $ bh { baseUrlPort = port }
in cors { _corsAllowedOrigins = origins <> Prelude.map mkUrl origins } in cors { _corsAllowedOrigins = origins <> Prelude.map mkUrl origins }
-- | Loads the 'CORSSettings' from the 'toml' file. -- | Loads the 'CORSSettings' from the 'toml' file.
...@@ -48,5 +46,7 @@ loadGargTomlSettings tomlFile = do ...@@ -48,5 +46,7 @@ loadGargTomlSettings tomlFile = do
logMsg ioLogger ERROR $ T.unpack $ "Error, gargantext-settings.toml parsing failed: " <> Toml.prettyTomlDecodeErrors errs 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." panicTrace "Please fix the errors in your gargantext-settings.toml file."
Right settings0 -> case settings0 ^. gargCorsSettings . corsUseOriginsForHosts of Right settings0 -> case settings0 ^. gargCorsSettings . corsUseOriginsForHosts of
True -> pure $ addProxyToAllowedOrigins $ settings0 & over (gargCorsSettings . corsAllowedHosts) (\_ -> "http://localhost:3000" : (settings0 ^. gargCorsSettings . corsAllowedOrigins)) True -> pure $ addProxyToAllowedOrigins $
False -> pure $ addProxyToAllowedOrigins $ settings0 & over (gargCorsSettings . corsAllowedHosts) ("http://localhost:3000" :) settings0 & over (gargCorsSettings . corsAllowedHosts)
(\_ -> (settings0 ^. gargCorsSettings . corsAllowedOrigins))
False -> pure $ addProxyToAllowedOrigins settings0
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
module Gargantext.API.Node.ShareURL where module Gargantext.API.Node.ShareURL where
import Data.Text import Control.Lens
import Gargantext.Prelude 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.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.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) import Servant.Server.Generic (AsServerT)
shareURL :: IsGargServer env err m => Named.ShareURL (AsServerT m) shareURL :: IsGargServer env err m => Named.ShareURL (AsServerT m)
...@@ -19,14 +24,33 @@ shareURL = Named.ShareURL getUrl ...@@ -19,14 +24,33 @@ shareURL = Named.ShareURL getUrl
getUrl :: (IsGargServer env err m, CmdCommon env) getUrl :: (IsGargServer env err m, CmdCommon env)
=> Maybe NodeType => Maybe NodeType
-> Maybe NodeId -> Maybe NodeId
-> m Text -> m Named.ShareLink
getUrl nt id = do getUrl nt id = do
-- TODO add check that the node is able to be shared (in a shared folder) -- TODO add check that the node is able to be shared (in a shared folder)
case nt of gc <- view hasConfig
Nothing -> pure "Invalid node Type" urlPort <- view settings
Just t -> case get_url nt id gc urlPort of
case id of Left err -> throwError $ _ValidationError # (V.check False err)
Nothing -> pure "Invalid node ID" Right shareLink -> pure shareLink
Just i -> do
url <- view $ hasConfig . gc_url get_url :: Maybe NodeType
pure $ url <> "/#/share/" <> show t <> "/" <> show (unNodeId i) -> 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' ...@@ -92,7 +92,7 @@ data GargPrivateAPI' mode = GargPrivateAPI'
, listGetAPI :: mode :- NamedRoutes List.GETAPI , listGetAPI :: mode :- NamedRoutes List.GETAPI
, listJsonAPI :: mode :- NamedRoutes List.JSONAPI , listJsonAPI :: mode :- NamedRoutes List.JSONAPI
, listTsvAPI :: mode :- NamedRoutes List.TSVAPI , listTsvAPI :: mode :- NamedRoutes List.TSVAPI
, shareUrlEp :: mode :- "shareurl" :> NamedRoutes ShareURL , shareUrlAPI :: mode :- "shareurl" :> NamedRoutes ShareURL
} deriving Generic } deriving Generic
......
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
module Gargantext.API.Routes.Named.Share ( module Gargantext.API.Routes.Named.Share (
-- * Routes types -- * Routes types
ShareNode(..) ShareNode(..)
, Unpublish(..) , Unpublish(..)
, ShareURL(..) , ShareURL(..)
, ShareLink(..)
, renderShareLink
-- * API types (which appears in the routes) -- * API types (which appears in the routes)
, ShareNodeParams(..) , ShareNodeParams(..)
) where ) where
import Data.Text (Text) import Data.Aeson
import Data.Swagger
import Data.Text qualified as T
import GHC.Generics import GHC.Generics
import Gargantext.API.Node.Share.Types ( ShareNodeParams (..) ) import Gargantext.API.Node.Share.Types ( ShareNodeParams (..) )
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Network.URI (parseURI)
import Prelude import Prelude
import Servant 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 newtype ShareURL mode = ShareURL
{ shareUrlEp :: mode :- Summary "Fetch URL for sharing a node" { shareUrlEp :: mode :- Summary "Fetch URL for sharing a node"
:> QueryParam "type" NodeType :> QueryParam "type" NodeType
:> QueryParam "id" NodeId :> QueryParam "id" NodeId
:> Get '[JSON] Text :> Get '[JSON] ShareLink
} deriving Generic } deriving Generic
......
...@@ -63,5 +63,5 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId) ...@@ -63,5 +63,5 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
, listGetAPI = List.getAPI , listGetAPI = List.getAPI
, listJsonAPI = List.jsonAPI , listJsonAPI = List.jsonAPI
, listTsvAPI = List.tsvAPI , listTsvAPI = List.tsvAPI
, shareUrlEp = shareURL , shareUrlAPI = shareURL
} }
...@@ -36,8 +36,8 @@ instance ToSchema Value where declareNamedSchema _ = declareNamedSchema (Proxy : ...@@ -36,8 +36,8 @@ instance ToSchema Value where declareNamedSchema _ = declareNamedSchema (Proxy :
-- 'purescript-gargantext' package. -- 'purescript-gargantext' package.
data PhyloData = PhyloData { pd_corpusId :: NodeId data PhyloData = PhyloData { pd_corpusId :: NodeId
, pd_listId :: NodeId , pd_listId :: NodeId
, pd_data :: GraphData , pd_data :: Maybe GraphData
, pd_config :: PhyloConfig , pd_config :: Maybe PhyloConfig
} }
deriving (Generic, Show, Eq) deriving (Generic, Show, Eq)
......
...@@ -21,7 +21,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(.. ...@@ -21,7 +21,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..
import Gargantext.Defaults qualified as Defaults import Gargantext.Defaults qualified as Defaults
import Gargantext.Prelude hiding (intercalate) import Gargantext.Prelude hiding (intercalate)
import HAL qualified import HAL qualified
import HAL.Doc.Corpus qualified as HAL import HAL.Doc.Document qualified as HAL
import HAL.Types qualified as HAL import HAL.Types qualified as HAL
import Servant.Client (ClientError) import Servant.Client (ClientError)
...@@ -38,23 +38,23 @@ getC la q ml = do ...@@ -38,23 +38,23 @@ getC la q ml = do
-- Left err -> panic $ pack $ show err -- Left err -> panic $ pack $ show err
-- Right (len, docsC) -> pure (len, docsC .| mapMC (toDoc' la)) -- Right (len, docsC) -> pure (len, docsC .| mapMC (toDoc' la))
toDoc' :: Maybe ISO639.ISO639_1 -> HAL.Corpus -> IO HyperdataDocument toDoc' :: Maybe ISO639.ISO639_1 -> HAL.Document -> IO HyperdataDocument
toDoc' la (HAL.Corpus { .. }) = do toDoc' la (HAL.Document { .. }) = do
-- printDebug "[toDoc corpus] h" h -- 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 (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 let abstract = case la of
Nothing -> abstractDefault 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" pure HyperdataDocument { _hd_bdd = Just "Hal"
, _hd_doi = Just $ pack $ show _corpus_docid , _hd_doi = Just $ pack $ show _document_docid
, _hd_url = Nothing , _hd_url = Nothing
, _hd_page = Nothing , _hd_page = Nothing
, _hd_title = Just $ unwords _corpus_title , _hd_title = Just $ unwords _document_title
, _hd_authors = Just $ foldl' (\x y -> if x == "" then y else x <> ", " <> y) "" _corpus_authors_names , _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) "" $ _corpus_authors_affiliations <> map show _corpus_struct_id , _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 _corpus_source , _hd_source = Just $ maybe "Nothing" identity _document_source
, _hd_abstract = Just abstract , _hd_abstract = Just abstract
, _hd_publication_date = fmap show utctime , _hd_publication_date = fmap show utctime
, _hd_publication_year = pub_year , _hd_publication_year = pub_year
......
...@@ -20,6 +20,9 @@ import Data.ByteString.Lazy qualified as BL ...@@ -20,6 +20,9 @@ import Data.ByteString.Lazy qualified as BL
import Data.Csv import Data.Csv
import Data.Text (pack) import Data.Text (pack)
import Data.Text qualified as T 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.Time.Segment (jour)
import Data.Vector (Vector) import Data.Vector (Vector)
import Data.Vector qualified as V import Data.Vector qualified as V
...@@ -205,7 +208,7 @@ hyperdataDocument2tsvDoc h = TsvDoc { tsv_title = m $ _hd_title h ...@@ -205,7 +208,7 @@ hyperdataDocument2tsvDoc h = TsvDoc { tsv_title = m $ _hd_title h
mI = maybe 0 identity mI = maybe 0 identity
data Delimiter = Tab | Comma data Delimiter = Tab | Comma | Line deriving (Eq, Show)
tsvDecodeOptions :: Delimiter -> DecodeOptions tsvDecodeOptions :: Delimiter -> DecodeOptions
tsvDecodeOptions d = defaultDecodeOptions {decDelimiter = delimiter d} tsvDecodeOptions d = defaultDecodeOptions {decDelimiter = delimiter d}
...@@ -216,6 +219,151 @@ tsvEncodeOptions d = defaultEncodeOptions {encDelimiter = delimiter d} ...@@ -216,6 +219,151 @@ tsvEncodeOptions d = defaultEncodeOptions {encDelimiter = delimiter d}
delimiter :: Delimiter -> Word8 delimiter :: Delimiter -> Word8
delimiter Tab = fromIntegral $ ord '\t' delimiter Tab = fromIntegral $ ord '\t'
delimiter Comma = fromIntegral $ ord ',' 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 ...@@ -251,10 +399,10 @@ readByteStringStrict d ff = readByteStringLazy d ff . BL.fromStrict
-- | TODO use readFileLazy -- | TODO use readFileLazy
readTSVFile :: FilePath -> IO (Either Text (Header, Vector TsvDoc)) readTSVFile :: FilePath -> IO (Either Text (Header, Vector TsvDoc))
readTSVFile fp = do readTSVFile fp = do
result <- readTsvLazyBS Comma <$> BL.readFile fp file <- BL.readFile fp
case result of case (testCorrectFile file) of
Left _err -> readTsvLazyBS Tab <$> BL.readFile fp Left _err -> pure $ Left _err
Right res -> pure $ Right res Right del -> pure $ readTsvLazyBS del file
......
...@@ -28,7 +28,6 @@ import Gargantext.Core.Types.Phylo (GraphData(..)) ...@@ -28,7 +28,6 @@ import Gargantext.Core.Types.Phylo (GraphData(..))
import Gargantext.Core.Viz.LegacyPhylo hiding (Phylo(..)) import Gargantext.Core.Viz.LegacyPhylo hiding (Phylo(..))
import Gargantext.Core.Viz.Phylo (PhyloConfig(..), defaultConfig, _phylo_param, _phyloParam_config) import Gargantext.Core.Viz.Phylo (PhyloConfig(..), defaultConfig, _phylo_param, _phyloParam_config)
import Gargantext.Core.Viz.Phylo.API.Tools 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.Hyperdata
import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..)) import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, defaultList) import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, defaultList)
...@@ -58,21 +57,27 @@ getPhylo phyloId = Named.GetPhylo $ \lId _level _minSizeBranch -> do ...@@ -58,21 +57,27 @@ getPhylo phyloId = Named.GetPhylo $ \lId _level _minSizeBranch -> do
listId <- case lId of listId <- case lId of
Nothing -> defaultList corpusId Nothing -> defaultList corpusId
Just ld -> pure ld Just ld -> pure ld
(gd, phyloConfig) <- getPhyloDataJson phyloId pd <- getPhyloDataJson phyloId
-- printDebug "getPhylo" theData -- 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 getPhyloDataJson phyloId = do
maybePhyloData <- getPhyloData phyloId phyloData <- getPhyloData phyloId
let phyloData = fromMaybe phyloCleopatre maybePhyloData phyloJson <- liftBase $ maybePhylo2dot2json phyloData
let phyloConfig = _phyloParam_config $ _phylo_param phyloData case phyloJson of
phyloJson <- liftBase $ phylo2dot2json phyloData Nothing -> pure Nothing
case parseEither parseJSON phyloJson of Just pj ->
Left err -> panicTrace $ T.pack $ "[Gargantext.Core.Viz.Phylo.API] getPhyloDataJson: " <> err case parseEither parseJSON pj of
Right gd -> pure (gd, phyloConfig) 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 -- getPhyloDataSVG phId _lId l msb = do
......
...@@ -69,6 +69,10 @@ savePhylo :: PhyloId -> DBCmd err () ...@@ -69,6 +69,10 @@ savePhylo :: PhyloId -> DBCmd err ()
savePhylo = undefined savePhylo = undefined
-------------------------------------------------------------------- --------------------------------------------------------------------
maybePhylo2dot2json :: Maybe Phylo -> IO (Maybe Value)
maybePhylo2dot2json Nothing = pure Nothing
maybePhylo2dot2json (Just phylo) = Just <$> phylo2dot2json phylo
phylo2dot2json :: Phylo -> IO Value phylo2dot2json :: Phylo -> IO Value
phylo2dot2json phylo = do phylo2dot2json phylo = do
withTempDirectory "/tmp" "phylo" $ \dirPath -> do withTempDirectory "/tmp" "phylo" $ \dirPath -> do
......
...@@ -25,6 +25,7 @@ import Data.Text qualified as T ...@@ -25,6 +25,7 @@ import Data.Text qualified as T
import Gargantext.API.Admin.Settings.MicroServices import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.API.Admin.Types (settings, _microservicesSettings, HasSettings) import Gargantext.API.Admin.Types (settings, _microservicesSettings, HasSettings)
import Gargantext.Core import Gargantext.Core
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Core.Types (Name) import Gargantext.Core.Types (Name)
import Gargantext.Database.Admin.Types.Hyperdata import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Hyperdata.Default import Gargantext.Database.Admin.Types.Hyperdata.Default
...@@ -34,7 +35,6 @@ import Gargantext.Database.Query.Table.Node ...@@ -34,7 +35,6 @@ import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata) import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Prelude hiding (hash) import Gargantext.Prelude hiding (hash)
import Gargantext.Core.Config (GargConfig(..))
import Gargantext.Prelude.Crypto.Hash (hash) import Gargantext.Prelude.Crypto.Hash (hash)
import Servant.Client.Core.BaseUrl import Servant.Client.Core.BaseUrl
...@@ -96,8 +96,14 @@ mkNodeWithParent_ConfigureHyperdata NodeFrameNotebook (Just i) uId name = (:[]) ...@@ -96,8 +96,14 @@ mkNodeWithParent_ConfigureHyperdata NodeFrameNotebook (Just i) uId name = (:[])
mkNodeWithParent_ConfigureHyperdata _ _ _ _ = nodeError NotImplYet mkNodeWithParent_ConfigureHyperdata _ _ _ _ = nodeError NotImplYet
internalNotesProxy :: BaseUrl -> T.Text -- | Creates the base URL for the notes microservices proxy, or defaults
internalNotesProxy proxyUrl = T.pack $ showBaseUrl proxyUrl <> "/notes" -- 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 -- | Function not exposed
mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType, HasSettings env) mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType, HasSettings env)
...@@ -116,7 +122,7 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do ...@@ -116,7 +122,7 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
cfg <- view hasConfig cfg <- view hasConfig
stt <- view settings stt <- view settings
u <- case nt of u <- case nt of
Notes -> pure $ internalNotesProxy (mkProxyUrl cfg $ _microservicesSettings stt) Notes -> pure $ internalNotesProxy cfg (_microservicesSettings stt)
Calc -> pure $ _gc_frame_calc_url cfg Calc -> pure $ _gc_frame_calc_url cfg
NodeFrameVisio -> pure $ _gc_frame_visio_url cfg NodeFrameVisio -> pure $ _gc_frame_visio_url cfg
_ -> nodeError NeedsConfiguration _ -> nodeError NeedsConfiguration
......
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Gargantext.MicroServices.ReverseProxy ( module Gargantext.MicroServices.ReverseProxy (
microServicesProxyApp microServicesProxyApp
...@@ -24,34 +25,41 @@ import Conduit ...@@ -24,34 +25,41 @@ import Conduit
import Data.ByteString qualified as B import Data.ByteString qualified as B
import Data.ByteString.Builder import Data.ByteString.Builder
import Data.ByteString.Char8 qualified as C8 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.Conduit.List qualified as CC
import Data.String import Data.String
import Data.Text qualified as T import Data.Text qualified as T
import Data.Text.Encoding qualified as TE import Data.Text.Encoding qualified as TE
import GHC.Generics import GHC.Generics
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.EnvTypes import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Settings.MicroServices import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.API.Admin.Types import Gargantext.API.Admin.Types
import Gargantext.API.Node.ShareURL qualified as Share
import Gargantext.API.Routes.Named.Private import Gargantext.API.Routes.Named.Private
import Gargantext.API.Routes.Named.Share (ShareLink(..))
import Gargantext.API.ThrowAll (throwAllRoutes) import Gargantext.API.ThrowAll (throwAllRoutes)
import Gargantext.API.Types (HTML)
import Gargantext.Core.Config (gc_frame_write_url) import Gargantext.Core.Config (gc_frame_write_url)
import Gargantext.Database.Admin.Types.Node (NodeType(..), NodeId (..))
import Gargantext.Database.Prelude (hasConfig) import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Prelude hiding (Handler) import Gargantext.Prelude hiding (Handler)
import Network.HTTP.ReverseProxy import Network.HTTP.ReverseProxy
import Network.HTTP.Types (hCacheControl, RequestHeaders, hReferer, ResponseHeaders, Header) 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 hiding (Header)
import Servant.Auth.Server import Servant.Auth.Server
import Servant.Auth.Server.Internal.AddSetCookie
import Servant.Auth.Swagger () import Servant.Auth.Swagger ()
import Servant.Client.Core.BaseUrl import Servant.Client.Core.BaseUrl
import Servant.Server.Generic import Servant.Server.Generic
import Text.RE.Replace hiding (Capture) import Text.RE.Replace hiding (Capture)
import Text.RE.TDFA.ByteString 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 -- See https://github.com/haskell-servant/servant/issues/1601#issue-1338013029
instance {-# OVERLAPPING #-} instance {-# OVERLAPPING #-}
...@@ -66,7 +74,7 @@ instance {-# OVERLAPPING #-} ...@@ -66,7 +74,7 @@ instance {-# OVERLAPPING #-}
-- --
newtype FrameId = FrameId { _FrameId :: T.Text } newtype FrameId = FrameId { _FrameId :: T.Text }
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord, Hashable)
instance ToHttpApiData FrameId where instance ToHttpApiData FrameId where
toUrlPiece = toUrlPiece . _FrameId toUrlPiece = toUrlPiece . _FrameId
...@@ -122,7 +130,7 @@ data NotesProxy mode = NotesProxy ...@@ -122,7 +130,7 @@ data NotesProxy mode = NotesProxy
-- | The config file which contains the server settings for the websocket connection -- | The config file which contains the server settings for the websocket connection
-- that we have to overwrite with our settings. -- 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 -- | Once the connection has been established, this is the websocket endpoint to
-- poll edits. -- poll edits.
...@@ -132,7 +140,9 @@ data NotesProxy mode = NotesProxy ...@@ -132,7 +140,9 @@ data NotesProxy mode = NotesProxy
, meEndpoint :: mode :- "me" :> Raw , meEndpoint :: mode :- "me" :> Raw
-- | The initial endpoint which will be hit the first time we want to access the /notes endpoint. -- | 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. -- | The generic routes serving the assets.
, notesStaticAssets :: mode :- Raw , notesStaticAssets :: mode :- Raw
...@@ -146,48 +156,68 @@ data SocketIOProxy mode = SocketIOProxy ...@@ -146,48 +156,68 @@ data SocketIOProxy mode = SocketIOProxy
-- The Server -- The Server
-- --
microServicesProxyApp :: Env -> Application type ProxyCache = InMemory.Cache FrameId NodeId
microServicesProxyApp env = genericServeTWithContext id (server env) cfg
microServicesProxyApp :: ProxyCache -> Env -> Application
microServicesProxyApp cache env = genericServeTWithContext id (server cache env) cfg
where where
cfg :: Context AuthContext cfg :: Context AuthContext
cfg = env ^. settings . jwtSettings cfg = env ^. settings . jwtSettings
:. env ^. settings . cookieSettings :. env ^. settings . cookieSettings
:. EmptyContext :. EmptyContext
server :: Env -> ReverseProxyAPI (AsServerT Handler) server :: ProxyCache -> Env -> ReverseProxyAPI (AsServerT Handler)
server env = ReverseProxyAPI { server cache env = ReverseProxyAPI {
notesServiceProxy = \case notesServiceProxy = \case
(Authenticated _autUser) -> notesProxyImplementation env (Authenticated _autUser) -> notesProxyImplementation cache env
_ -> throwAllRoutes err401 $ notesProxyImplementation env _ -> throwAllRoutes err401 $ notesProxyImplementation cache env
, proxyPassAll = proxyPassServer ST_notes 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 -- 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 -- 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 -- 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 -- (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`. -- as it would try to establish a connection to `noteId=notes`.
configJS :: BaseUrl -> ServiceType -> T.Text customiseConfigJS :: BaseUrl -> ServiceType -> ConduitT B.ByteString (Flush Builder) IO ()
configJS bu st = T.pack $ [r| customiseConfigJS bu st = CC.map flushReplace
window.domain = '|] <> (baseUrlHost bu) <> [r|' where
window.urlpath = '|] <> renderServiceType st <> [r|' -- Replaces the relative links in the proxied page content with proper urls.
window.debug = false flushReplace :: B.ByteString -> Flush Builder
window.version = '1.2.0' 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 :: ProxyCache -> Env -> NotesProxy AsServer
notesProxyImplementation env = NotesProxy { notesProxyImplementation cache env = NotesProxy {
slideEp = \frameId -> slideProxyServer env frameId slideEp = \frameId -> slideProxyServer env frameId
, publishEp = \frameId -> publishProxyServer env frameId , publishEp = \frameId -> publishProxyServer cache env frameId
, configFile = pure $ configJS (proxyUrl env) sty , configFile = defaultForwardServerWithSettings sty id env (configFileSettings env sty)
, notesSocket = socketIOProxyImplementation sty env , notesSocket = socketIOProxyImplementation sty env
, meEndpoint = proxyPassServer 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 , notesStaticAssets = proxyPassServer sty env
} }
where where
...@@ -196,7 +226,7 @@ notesProxyImplementation env = NotesProxy { ...@@ -196,7 +226,7 @@ notesProxyImplementation env = NotesProxy {
socketIOProxyImplementation :: ServiceType -> Env -> SocketIOProxy AsServer socketIOProxyImplementation :: ServiceType -> Env -> SocketIOProxy AsServer
socketIOProxyImplementation sty env = SocketIOProxy { socketIOProxyImplementation sty env = SocketIOProxy {
socketIoEp = \_noteId -> defaultForwardServer sty id env socketIoEp = \_noteId -> defaultForwardServer sty id id env
} }
removeServiceFromPath :: ServiceType -> Request -> Request removeServiceFromPath :: ServiceType -> Request -> Request
...@@ -208,21 +238,42 @@ removeServiceFromPath sty = removeProxyPath (T.pack $ serviceTypeToProxyPath sty ...@@ -208,21 +238,42 @@ removeServiceFromPath sty = removeProxyPath (T.pack $ serviceTypeToProxyPath sty
slideProxyServer :: Env -> FrameId -> ServerT Raw m slideProxyServer :: Env -> FrameId -> ServerT Raw m
slideProxyServer env (FrameId frameId) = 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 where
changePath :: ByteString -> ByteString changePath :: ByteString -> ByteString
changePath _ = TE.encodeUtf8 $ "/p/" <> frameId <> "#/" changePath _ = TE.encodeUtf8 $ "/p/" <> frameId <> "#/"
publishProxyServer :: Env -> FrameId -> ServerT Raw m -- | Rather than using the publish feature of HedgeDoc / CodiMD, we rely on our
publishProxyServer env (FrameId frameId) = -- own URL sharing feauture.
defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) env 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 where
forwardRaw =
unTagged (defaultForwardServer ST_notes (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) id env)
changePath :: ByteString -> ByteString changePath :: ByteString -> ByteString
changePath _ = TE.encodeUtf8 $ "/s/" <> frameId changePath _ = TE.encodeUtf8 $ "/s/" <> (_FrameId frameId)
-- Generic server forwarder -- Generic server forwarder
proxyPassServer :: ServiceType -> Env -> ServerT Raw m 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 -> ProxyDestination
mkProxyDestination env = fromMaybe (panicTrace "Invalid URI found in the proxied Request.") $ do mkProxyDestination env = fromMaybe (panicTrace "Invalid URI found in the proxied Request.") $ do
...@@ -248,12 +299,35 @@ removeFromReferer pth originalRequest = ...@@ -248,12 +299,35 @@ removeFromReferer pth originalRequest =
proxyUrl :: Env -> BaseUrl proxyUrl :: Env -> BaseUrl
proxyUrl env = mkProxyUrl (env ^. hasConfig) (env ^. env_settings . microservicesSettings) proxyUrl env = mkProxyUrl (env ^. hasConfig) (env ^. env_settings . microservicesSettings)
notesForwardServer :: ProxyCache
defaultForwardServer :: ServiceType -> FrameId
-> (Request -> Request) -> Maybe NodeId
-> Env -> ServiceType
-> ServerT Raw m -> (Request -> Request)
defaultForwardServer sty presendModifyRequest env = -> 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) Tagged $ waiProxyToSettings forwardRequest (proxySettings) (env ^. env_manager)
where where
...@@ -263,14 +337,6 @@ defaultForwardServer sty presendModifyRequest env = ...@@ -263,14 +337,6 @@ defaultForwardServer sty presendModifyRequest env =
proxyUrlStr :: String proxyUrlStr :: String
proxyUrlStr = showBaseUrl (proxyUrl env) 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 :: ProxyDestination -> RequestHeaders -> RequestHeaders
setHost hst hdrs = (hHost, fwdHost hst) : filter ((/=) hHost . fst) hdrs setHost hst hdrs = (hHost, fwdHost hst) : filter ((/=) hHost . fst) hdrs
...@@ -287,6 +353,27 @@ defaultForwardServer sty presendModifyRequest env = ...@@ -287,6 +353,27 @@ defaultForwardServer sty presendModifyRequest env =
} }
pure $ WPRModifiedRequest proxiedReq (ProxyDest (fwdHost proxyDestination) (fwdPort proxyDestination)) 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 -- Utility functions
-- --
...@@ -306,12 +393,15 @@ tweakResponseHeaders = Prelude.map tweakHeader ...@@ -306,12 +393,15 @@ tweakResponseHeaders = Prelude.map tweakHeader
= (k,v) = (k,v)
-- | Replaces the relative links in any HTML blob returned by the proxy. -- | Replaces the relative links in any HTML blob returned by the proxy.
replaceRelativeLinks :: B.ByteString -> ConduitT B.ByteString (Flush Builder) IO () replaceRelativeLinks :: ProxyDestination -> B.ByteString -> ConduitT B.ByteString (Flush Builder) IO ()
replaceRelativeLinks assetPath = CC.map flushReplace replaceRelativeLinks proxyTarget assetPath = CC.map flushReplace
where where
-- Replaces the relative links in the proxied page content with proper urls. -- Replaces the relative links in the proxied page content with proper urls.
flushReplace :: B.ByteString -> Flush Builder 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 :: B.ByteString -> B.ByteString
replaceIt htmlBlob = replaceIt htmlBlob =
......
...@@ -15,6 +15,7 @@ ...@@ -15,6 +15,7 @@
- "hspec-core-2.11.1" - "hspec-core-2.11.1"
- "hspec-discover-2.11.1" - "hspec-discover-2.11.1"
- "hspec-expectations-0.8.3" - "hspec-expectations-0.8.3"
- "http-accept-0.2"
- "ihaskell-0.11.0.0" - "ihaskell-0.11.0.0"
- "ipython-kernel-0.11.0.0" - "ipython-kernel-0.11.0.0"
- "located-base-0.1.1.1" - "located-base-0.1.1.1"
...@@ -48,6 +49,7 @@ ...@@ -48,6 +49,7 @@
- "validation-selective-0.2.0.0" - "validation-selective-0.2.0.0"
- "vector-0.12.3.0" - "vector-0.12.3.0"
- "wai-3.2.4" - "wai-3.2.4"
- "wai-util-0.8"
- commit: 2b5d69448557e89002c0179ea1aaf59bb757a6e3 - commit: 2b5d69448557e89002c0179ea1aaf59bb757a6e3
git: "https://github.com/AccelerateHS/accelerate-llvm.git" git: "https://github.com/AccelerateHS/accelerate-llvm.git"
subdirs: subdirs:
...@@ -132,7 +134,7 @@ ...@@ -132,7 +134,7 @@
git: "https://gitlab.iscpif.fr/gargantext/crawlers/epo-proxy-api.git" git: "https://gitlab.iscpif.fr/gargantext/crawlers/epo-proxy-api.git"
subdirs: subdirs:
- . - .
- commit: 3a7d039e07c8564e8ff84ef88480924d18aa5018 - commit: 1dbd939257d33126e49d2679375553df1f2eebc5
git: "https://gitlab.iscpif.fr/gargantext/crawlers/hal.git" git: "https://gitlab.iscpif.fr/gargantext/crawlers/hal.git"
subdirs: subdirs:
- . - .
...@@ -519,6 +521,9 @@ flags: ...@@ -519,6 +521,9 @@ flags:
"optimised-mixer": false "optimised-mixer": false
"streaming-commons": "streaming-commons":
"use-bytestring-builder": false "use-bytestring-builder": false
stringsearch:
base3: false
base4: true
tagged: tagged:
deepseq: true deepseq: true
transformers: true transformers: true
......
...@@ -19,6 +19,6 @@ allowed-origins = [ ...@@ -19,6 +19,6 @@ allowed-origins = [
use-origins-for-hosts = true use-origins-for-hosts = true
[microservices] [microservices.proxy]
port = 8009
proxy-port = 8009 enabled = false
...@@ -7,29 +7,29 @@ module Test.API.Private ( ...@@ -7,29 +7,29 @@ module Test.API.Private (
tests tests
) where ) 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.Core.Types.Individu
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
import Gargantext.Prelude hiding (get) import Gargantext.Prelude hiding (get)
import Network.HTTP.Client hiding (Proxy) import Network.HTTP.Client hiding (Proxy)
import Network.Wai
import Servant.Auth.Client () import Servant.Auth.Client ()
import Servant.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.Routes (mkUrl)
import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob) import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
import Test.Database.Types
import Test.Hspec import Test.Hspec
import Test.Hspec.Wai hiding (pendingWith) import Test.Hspec.Wai hiding (pendingWith)
import Test.Hspec.Wai.Internal (withApplication) import Test.Hspec.Wai.Internal (withApplication)
import Test.Hspec.Wai.JSON (json) import Test.Hspec.Wai.JSON (json)
import Test.Utils (protected, shouldRespondWithFragment, withValidLogin) 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
privateTests :: SpecWith ((TestEnv, Int), Application)
tests :: Spec privateTests =
tests = sequential $ aroundAll withTestDBAndPort $ do
describe "Prelude" $ do
it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
describe "Private API" $ do describe "Private API" $ do
baseUrl <- runIO $ parseBaseUrl "http://localhost" baseUrl <- runIO $ parseBaseUrl "http://localhost"
manager <- runIO $ newManager defaultManagerSettings manager <- runIO $ newManager defaultManagerSettings
...@@ -90,3 +90,13 @@ tests = sequential $ aroundAll withTestDBAndPort $ do ...@@ -90,3 +90,13 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
withApplication app $ do withApplication app $ do
withValidLogin port "alice" (GargPassword "alice") $ \token -> do withValidLogin port "alice" (GargPassword "alice") $ \token -> do
protected token "GET" (mkUrl port "/tree/1") "" `shouldRespondWith` 403 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 ...@@ -7,6 +7,8 @@ import Control.Concurrent.Async qualified as Async
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Lens import Control.Lens
import Control.Monad.Reader import Control.Monad.Reader
import Data.Cache qualified as InMemory
import Data.Streaming.Network (bindPortTCP)
import Gargantext.API (makeApp) import Gargantext.API (makeApp)
import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..)) import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..))
import Gargantext.API.Admin.Settings import Gargantext.API.Admin.Settings
...@@ -47,8 +49,7 @@ import Servant.Client ...@@ -47,8 +49,7 @@ import Servant.Client
import Servant.Job.Async qualified as ServantAsync import Servant.Job.Async qualified as ServantAsync
import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo, fakeSettingsPath) import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo, fakeSettingsPath)
import Test.Database.Types import Test.Database.Types
import qualified UnliftIO import UnliftIO qualified
import Data.Streaming.Network (bindPortTCP)
newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port -> IO Env newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port -> IO Env
...@@ -137,9 +138,10 @@ withBackendServerAndProxy action = ...@@ -137,9 +138,10 @@ withBackendServerAndProxy action =
gargApp <- withLoggerHoisted Mock $ \ioLogger -> do gargApp <- withLoggerHoisted Mock $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080 env <- newTestEnv testEnv ioLogger 8080
makeApp env makeApp env
proxyCache <- InMemory.newCache Nothing
proxyApp <- withLoggerHoisted Mock $ \ioLogger -> do proxyApp <- withLoggerHoisted Mock $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080 env <- newTestEnv testEnv ioLogger 8080
pure $ microServicesProxyApp env pure $ microServicesProxyApp proxyCache env
Warp.testWithApplication (pure gargApp) $ \serverPort -> Warp.testWithApplication (pure gargApp) $ \serverPort ->
testWithApplicationOnPort (pure proxyApp) proxyPort $ 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 ...@@ -38,6 +38,7 @@ writeFrameTests = sequential $ aroundAll withBackendServerAndProxy $ do
& ($ (Token "bogus")) & ($ (Token "bogus"))
& notesEp & notesEp
& ($ (FrameId "abcdef")) & ($ (FrameId "abcdef"))
& ($ Nothing)
& ($ "GET") & ($ "GET")
) (clientEnv proxyPort) ) (clientEnv proxyPort)
...@@ -66,6 +67,7 @@ writeFrameTests = sequential $ aroundAll withBackendServerAndProxy $ do ...@@ -66,6 +67,7 @@ writeFrameTests = sequential $ aroundAll withBackendServerAndProxy $ do
& ($ (toServantToken $ autRes ^. authRes_token)) & ($ (toServantToken $ autRes ^. authRes_token))
& notesEp & notesEp
& ($ (FrameId "abcdef")) & ($ (FrameId "abcdef"))
& ($ Nothing)
& ($ "GET") & ($ "GET")
) (clientEnv proxyPort) ) (clientEnv proxyPort)
......
...@@ -13,6 +13,7 @@ module Main where ...@@ -13,6 +13,7 @@ module Main where
import Gargantext.Prelude import Gargantext.Prelude
import qualified Test.Core.Text.Corpus.Query as CorpusQuery 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.Core.Utils as Utils
import qualified Test.Graph.Clustering as Graph import qualified Test.Graph.Clustering as Graph
import qualified Test.Ngrams.NLP as NLP import qualified Test.Ngrams.NLP as NLP
...@@ -50,6 +51,7 @@ main = do ...@@ -50,6 +51,7 @@ main = do
, jobsSpec , jobsSpec
, NgramsQuery.tests , NgramsQuery.tests
, CorpusQuery.tests , CorpusQuery.tests
, TSVParser.tests
, JSON.tests , JSON.tests
, Errors.tests , Errors.tests
, similaritySpec , 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