Skip to content

haskell-gargantext
haskell-gargantext
Commit 788a943e authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

Merge branch 'dev' into testing

parents 2e83eaa8 c262ec0e
Hide whitespace changes
Inline Side-by-side
Showing with 638 additions and 251 deletions
CHANGELOG.md
View file @ 788a943e
## 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 ## 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) * [BACK][SECURITY][Allow the microservices proxy to be disabled or enabled by configuration settings (#369)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/369)
......
README.md
View file @ 788a943e
...@@ -188,6 +188,13 @@ When a devlopment is needed on libraries (for instance, the HAL crawler in https ...@@ -188,6 +188,13 @@ 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)
......
bin/update-project-dependencies
View file @ 788a943e
...@@ -18,8 +18,8 @@ fi ...@@ -18,8 +18,8 @@ fi
# with the `sha256sum` result calculated on the `cabal.project` and # with the `sha256sum` result calculated on the `cabal.project` and
# `cabal.project.freeze`. This ensures the files stay deterministic so that CI # `cabal.project.freeze`. This ensures the files stay deterministic so that CI
# cache can kick in. # cache can kick in.
expected_cabal_project_hash="ec368714e0d4213dcc60e7c98344ab9a4ecbcff522deb4c57a12490e3b048585" expected_cabal_project_hash="c2c8ffc22f513f962745a00db6f9199eca89066ecbb47c850e5969550a4e6e1e"
expected_cabal_project_freeze_hash="ca1592c985ffead024c6635eb39b293e2525a547fe93293fdee9ce1148083f22" expected_cabal_project_freeze_hash="05ee74fc30b25edf135f4f9c53a2c134752184545b7a9e837f27e36d507a7a80"
cabal --store-dir=$STORE_DIR v2-build --dry-run cabal --store-dir=$STORE_DIR v2-build --dry-run
cabal2stack --system-ghc --allow-newer --resolver lts-21.17 --resolver-file devops/stack/lts-21.17.yaml -o stack.yaml cabal2stack --system-ghc --allow-newer --resolver lts-21.17 --resolver-file devops/stack/lts-21.17.yaml -o stack.yaml
......
cabal.project
View file @ 788a943e
...@@ -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: 3665ccda54893d01bb27220538eefdde0c1e7419 tag: 1dbd939257d33126e49d2679375553df1f2eebc5
source-repository-package source-repository-package
type: git type: git
......
cabal.project.freeze
View file @ 788a943e
...@@ -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,
...@@ -274,6 +275,7 @@ constraints: any.Cabal ==3.8.1.0, ...@@ -274,6 +275,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,
...@@ -545,6 +547,8 @@ constraints: any.Cabal ==3.8.1.0, ...@@ -545,6 +547,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,
...@@ -654,6 +658,7 @@ constraints: any.Cabal ==3.8.1.0, ...@@ -654,6 +658,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,
......
docs/editor_setup.md 0 → 100644
View file @ 788a943e
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.
docs/running_commands.md 0 → 100644
View file @ 788a943e
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.
gargantext-settings.toml
View file @ 788a943e
...@@ -15,6 +15,7 @@ allowed-origins = [ ...@@ -15,6 +15,7 @@ allowed-origins = [
, "https://msh.sub.gargantext.org" , "https://msh.sub.gargantext.org"
, "https://dev.sub.gargantext.org" , "https://dev.sub.gargantext.org"
, "http://localhost:8008" , "http://localhost:8008"
, "http://localhost:3000"
] ]
use-origins-for-hosts = true use-origins-for-hosts = true
......
gargantext.cabal
View file @ 788a943e
...@@ -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.11 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
...@@ -520,10 +520,12 @@ library ...@@ -520,10 +520,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
...@@ -662,6 +664,7 @@ library ...@@ -662,6 +664,7 @@ library
, split ^>= 0.2.3.4 , split ^>= 0.2.3.4
, stemmer ^>= 0.5.2 , stemmer ^>= 0.5.2
, stm ^>= 2.5.0.1 , stm ^>= 2.5.0.1
, 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
...@@ -689,6 +692,7 @@ library ...@@ -689,6 +692,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
...@@ -778,61 +782,17 @@ executable gargantext-server ...@@ -778,61 +782,17 @@ executable gargantext-server
, unordered-containers ^>= 0.2.16.0 , unordered-containers ^>= 0.2.16.0
, vector ^>= 0.7.3 , vector ^>= 0.7.3
test-suite garg-test-tasty common testDependencies
import:
defaults
type: exitcode-stdio-1.0
main-is: drivers/tasty/Main.hs
other-modules:
Test.API.Routes
CLI.Phylo.Common
Test.API.Setup
Test.Core.Similarity
Test.Core.Text
Test.Core.Text.Corpus.Query
Test.Core.Text.Corpus.TSV
Test.Core.Text.Examples
Test.Core.Text.Flow
Test.Core.Utils
Test.Database.Operations
Test.Database.Operations.DocumentSearch
Test.Database.Operations.NodeStory
Test.Database.Setup
Test.Database.Types
Test.Graph.Clustering
Test.Graph.Distance
Test.Ngrams.Lang
Test.Ngrams.Lang.En
Test.Ngrams.Lang.Fr
Test.Ngrams.Lang.Occurrences
Test.Ngrams.Metrics
Test.Ngrams.NLP
Test.Ngrams.Query
Test.Ngrams.Query.PaginationCorpus
Test.Offline.Errors
Test.Offline.JSON
Test.Offline.Phylo
Test.Offline.Stemming.Lancaster
Test.Parsers.Date
Test.Parsers.Types
Test.Parsers.WOS
Test.Server.ReverseProxy
Test.Types
Test.Utils
Test.Utils.Crypto
Test.Utils.Jobs
Paths_gargantext
hs-source-dirs:
test bin/gargantext-cli
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
build-depends: build-depends:
QuickCheck ^>= 2.14.2 base >=4.7 && <5
, QuickCheck ^>= 2.14.2
, aeson ^>= 1.5.6.0 , aeson ^>= 1.5.6.0
, aeson-pretty ^>= 0.8.9 , aeson-pretty ^>= 0.8.9
, aeson-qq , aeson-qq
, async ^>= 2.2.4 , async ^>= 2.2.4
, boolexpr ^>= 0.2 , boolexpr ^>= 0.2
, bytestring ^>= 0.10.12.0 , bytestring ^>= 0.10.12.0
, cache >= 0.1.3.0
, case-insensitive , case-insensitive
, conduit ^>= 1.3.4.2 , conduit ^>= 1.3.4.2
, containers ^>= 0.6.5.1 , containers ^>= 0.6.5.1
...@@ -878,9 +838,9 @@ test-suite garg-test-tasty ...@@ -878,9 +838,9 @@ test-suite garg-test-tasty
, servant-job , servant-job
, servant-server , servant-server
, shelly >= 1.9 && < 2 , shelly >= 1.9 && < 2
, split
, stm ^>= 2.5.0.1 , stm ^>= 2.5.0.1
, streaming-commons , streaming-commons
, split
, tasty ^>= 1.4.2.1 , tasty ^>= 1.4.2.1
, tasty-golden , tasty-golden
, tasty-hspec , tasty-hspec
...@@ -892,9 +852,9 @@ test-suite garg-test-tasty ...@@ -892,9 +852,9 @@ test-suite garg-test-tasty
, time ^>= 1.9.3 , time ^>= 1.9.3
, tmp-postgres >= 1.34.1 && < 1.35 , tmp-postgres >= 1.34.1 && < 1.35
, tree-diff , tree-diff
, unordered-containers ^>= 0.2.16.0
, unicode-collation >= 0.1.3.6 , unicode-collation >= 0.1.3.6
, unliftio , unliftio
, unordered-containers ^>= 0.2.16.0
, utf8-string ^>= 1.0.2 , utf8-string ^>= 1.0.2
, validity ^>= 0.11.0.1 , validity ^>= 0.11.0.1
, vector ^>= 0.12.3.0 , vector ^>= 0.12.3.0
...@@ -902,9 +862,59 @@ test-suite garg-test-tasty ...@@ -902,9 +862,59 @@ test-suite garg-test-tasty
, wai-extra , wai-extra
, warp , warp
test-suite garg-test-tasty
import:
defaults
, testDependencies
type: exitcode-stdio-1.0
main-is: drivers/tasty/Main.hs
other-modules:
Test.API.Routes
CLI.Phylo.Common
Test.API.Setup
Test.Core.Similarity
Test.Core.Text
Test.Core.Text.Corpus.Query
Test.Core.Text.Corpus.TSV
Test.Core.Text.Examples
Test.Core.Text.Flow
Test.Core.Utils
Test.Database.Operations
Test.Database.Operations.DocumentSearch
Test.Database.Operations.NodeStory
Test.Database.Setup
Test.Database.Types
Test.Graph.Clustering
Test.Graph.Distance
Test.Ngrams.Lang
Test.Ngrams.Lang.En
Test.Ngrams.Lang.Fr
Test.Ngrams.Lang.Occurrences
Test.Ngrams.Metrics
Test.Ngrams.NLP
Test.Ngrams.Query
Test.Ngrams.Query.PaginationCorpus
Test.Offline.Errors
Test.Offline.JSON
Test.Offline.Phylo
Test.Offline.Stemming.Lancaster
Test.Parsers.Date
Test.Parsers.Types
Test.Parsers.WOS
Test.Server.ReverseProxy
Test.Types
Test.Utils
Test.Utils.Crypto
Test.Utils.Jobs
Paths_gargantext
hs-source-dirs:
test bin/gargantext-cli
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
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:
...@@ -914,6 +924,7 @@ test-suite garg-test-hspec ...@@ -914,6 +924,7 @@ test-suite garg-test-hspec
Test.API.Errors Test.API.Errors
Test.API.GraphQL Test.API.GraphQL
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
...@@ -928,70 +939,6 @@ test-suite garg-test-hspec ...@@ -928,70 +939,6 @@ test-suite garg-test-hspec
hs-source-dirs: hs-source-dirs:
test test
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
build-depends:
QuickCheck ^>= 2.14.2
, aeson ^>= 1.5.6.0
, aeson-qq
, async ^>= 2.2.4
, boolexpr ^>= 0.2
, bytestring ^>= 0.10.12.0
, case-insensitive
, conduit ^>= 1.3.4.2
, containers ^>= 0.6.5.1
, crawlerArxiv
, extra ^>= 1.7.9
, fast-logger ^>= 3.0.5
, fmt
, gargantext
, gargantext-prelude
, hspec ^>= 2.7.10
, hspec-core
, hspec-expectations >= 0.8 && < 0.9
, hspec-wai
, hspec-wai-json
, http-api-data
, http-types
, http-client ^>= 0.6.4.1
, http-client-tls ^>= 0.3.5.3
, 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
, process ^>= 1.6.13.2
, 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-client
, servant-client
, servant-client-core
, servant-job
, servant-server
, shelly >= 1.9 && < 2
, stm ^>= 2.5.0.1
, streaming-commons
, tasty ^>= 1.4.2.1
, tasty-hspec
, tasty-hunit
, tasty-quickcheck
, tasty-smallcheck
, template-haskell
, text ^>= 1.2.4.1
, time ^>= 1.9.3
, tmp-postgres >= 1.34.1 && < 1.35
, tree-diff
, unliftio
, unordered-containers ^>= 0.2.16.0
, validity ^>= 0.11.0.1
, wai
, wai-extra
, warp
benchmark garg-bench benchmark garg-bench
main-is: Main.hs main-is: Main.hs
......
src/Gargantext/API.hs
View file @ 788a943e
...@@ -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)
...@@ -64,6 +66,8 @@ import Network.Wai.Middleware.Cors ...@@ -64,6 +66,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
...@@ -79,7 +83,8 @@ startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logge ...@@ -79,7 +83,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
...@@ -91,6 +96,7 @@ startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logge ...@@ -91,6 +96,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
...@@ -154,7 +160,7 @@ makeGargMiddleware :: CORSSettings -> Mode -> IO Middleware ...@@ -154,7 +160,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
...@@ -168,7 +174,7 @@ makeGargMiddleware crsSettings mode = do ...@@ -168,7 +174,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
......
src/Gargantext/API/Admin/Settings/CORS.hs
View file @ 788a943e
...@@ -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
......
src/Gargantext/API/Admin/Settings/TOML.hs
View file @ 788a943e
...@@ -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
src/Gargantext/API/Node/ShareURL.hs
View file @ 788a943e
{-# 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)
src/Gargantext/API/Routes/Named/Private.hs
View file @ 788a943e
...@@ -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
......
src/Gargantext/API/Routes/Named/Share.hs
View file @ 788a943e
{-# 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
......
src/Gargantext/API/Server/Named/Private.hs
View file @ 788a943e
...@@ -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
} }
src/Gargantext/API/Viz/Types.hs
View file @ 788a943e
...@@ -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)
......
src/Gargantext/Core/Text/Corpus/API/Hal.hs
View file @ 788a943e
...@@ -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
......
src/Gargantext/Core/Viz/Phylo/API.hs
View file @ 788a943e
...@@ -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
......
src/Gargantext/Core/Viz/Phylo/API/Tools.hs
View file @ 788a943e
...@@ -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
......
src/Gargantext/MicroServices/ReverseProxy.hs
View file @ 788a943e
{-# 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 =
......
stack.yaml
View file @ 788a943e
...@@ -14,6 +14,7 @@ ...@@ -14,6 +14,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"
...@@ -46,6 +47,7 @@ ...@@ -46,6 +47,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:
...@@ -126,7 +128,7 @@ ...@@ -126,7 +128,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: 3665ccda54893d01bb27220538eefdde0c1e7419 - commit: 1dbd939257d33126e49d2679375553df1f2eebc5
git: "https://gitlab.iscpif.fr/gargantext/crawlers/hal.git" git: "https://gitlab.iscpif.fr/gargantext/crawlers/hal.git"
subdirs: subdirs:
- . - .
...@@ -513,6 +515,9 @@ flags: ...@@ -513,6 +515,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
......
test/Test/API/Private.hs
View file @ 788a943e
...@@ -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
test/Test/API/Private/Share.hs 0 → 100644
View file @ 788a943e
{-# 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
test/Test/API/Setup.hs
View file @ 788a943e
...@@ -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
...@@ -44,8 +46,7 @@ import Servant.Client ...@@ -44,8 +46,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
...@@ -105,9 +106,10 @@ withBackendServerAndProxy action = ...@@ -105,9 +106,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 $
......
test/Test/Server/ReverseProxy.hs
View file @ 788a943e
...@@ -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)
......
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