Verified Commit 69ed7b65 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski

Merge branch 'dev' into 341-dev-websockets

parents 1f747d2e 0e037e1f
## 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][Integrate `servant-routes` in the codebase (#350)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/350)
* [BACK][FIX][[Documentation] Improve README (#365)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/365)
* [BACK][FIX][Improving message error from the TSV import (#361)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/361)
## Version 0.0.7.1.8 ## Version 0.0.7.1.8
* [BACK][FEAT][[Graph explorer] Search and associated documents (#262)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/262) (Backend Part). * [BACK][FEAT][[Graph explorer] Search and associated documents (#262)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/262) (Backend Part).
......
...@@ -7,12 +7,10 @@ ...@@ -7,12 +7,10 @@
#### Table of Contents #### Table of Contents
1. [About the project](#about) 1. [About the project](#about)
2. [Installation](#install) 2. [Installation and development](#install)
3. [Initialization](#init) 3. [Uses cases](#use-cases)
4. [Launch & develop GarganText](#launch) 4. [GraphQL](#graphql)
5. [Uses cases](#use-cases) 5. [PostgreSQL](#postgresql)
6. [GraphQL](#graphql)
7. [PostgreSQL](#postgresql)
## About the project <a name="about"></a> ## About the project <a name="about"></a>
...@@ -23,219 +21,112 @@ This software is free (as "Libre" in French) software, developed by the CNRS Com ...@@ -23,219 +21,112 @@ This software is free (as "Libre" in French) software, developed by the CNRS Com
GarganText Project: this repo builds the backend for the frontend server built by [backend](https://gitlab.iscpif.fr/gargantext/haskell-gargantext). GarganText Project: this repo builds the backend for the frontend server built by [backend](https://gitlab.iscpif.fr/gargantext/haskell-gargantext).
## Installation <a name="install"></a> ## Installation and development <a name="install"></a>
Disclaimer: since this project is still in development, this document remains in progress. Please report and improve this documentation if you encounter any issues. Disclaimer: since this project is still in development, this document remains in progress. Please report and improve this documentation if you encounter any issues.
#### Prerequisites ### Prerequisites
- Install: You must have the following installed:
- [git](https://git-scm.com/book/en/v2/Getting-Started-Installing-Git)
- [curl](https://everything.curl.dev/index.html)
- Clone the project.
```shell
git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
cd haskell-gargantext
```
### Installation
This project can be built with either Stack or Cabal. We keep up-to-date the `cabal.project` (which allows us - [Git](https://git-scm.com/book/en/v2/Getting-Started-Installing-Git)
to build with `cabal` by default) but we support `stack` thanks to thanks to - [Curl](https://everything.curl.dev/index.html)
[cabal2stack](https://github.com/iconnect/cabal2stack), which allows us to generate a valid `stack.yaml` from - [Nix](https://nixos.org/download/)
a `cabal.project`. Due to the fact gargantext requires a particular set of system dependencies (C++ libraries, - [Docker Compose](https://docs.docker.com/compose/install/)
toolchains, etc) we use [nix](https://nixos.org/) to setup an environment with all the required system
dependencies, in a sandboxed and isolated fashion.
#### Install Nix ### Building
As said, Gargantext requires [Nix](https://github.com/NixOS/nix) to provide system dependencies (for example, C libraries), but its use is limited to that. In order to install [Nix](https://nixos.org/download.html): #### Clone the projects
Clone both the backend (`haskell-gargantext`), and the frontend (`purescript-gargantext`) at the root of the backend.
```shell ```shell
sh <(curl -L https://nixos.org/nix/install) --daemon git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
``` cd haskell-gargantext
git clone https://gitlab.iscpif.fr/gargantext/purescript-gargantext.git
Verify the installation is complete with cd ..
```shell
nix-env --version
nix-env (Nix) 2.19.2
``` ```
**Important:** Before building the project with either `stack` or `cabal` you need to be in the correct Nix shell, which will fetch all the required system dependencies. To do so, just type **inside your haskell-gargantext folder**: #### Enter a Nix shell
Enter a Nix shell. This will take a long time the first time you run it:
```shell ```shell
nix-shell nix-shell
``` ```
This will take a bit of time as it has to download/build the dependencies, but this will be needed only the first time. You can exit a Nix shell at any point with `exit`.
### Build: choose cabal (new) or stack (old)
#### With Cabal (recommanded)
##### Turning off optimization flags
Create a `cabal.project.local` file (don't commit it to git!):
```
package gargantext
ghc-options: -fwrite-ide-info -hiedir=".stack-work/hiedb" -O0
package gargantext-admin
ghc-options: -O0
package gargantext-cli
ghc-options: -O0
package gargantext-db-obfuscation
ghc-options: -O0
package gargantext-import
ghc-options: -O0
package gargantext-init
ghc-options: -O0
package gargantext-invitations 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*.
ghc-options: -O0
package gargantext-phylo If for some reason you do not want to enter a Nix shell, you can still run a command from outside:
ghc-options: -O0
package gargantext-server
ghc-options: -O0
package gargantext-upgrade
ghc-options: -O0
package gargantext-graph
ghc-options: -O0
package hmatrix
ghc-options: -O0
package sparse-linear
ghc-options: -O0
```
##### Building
First, into `nix-shell`:
```shell ```shell
cabal update nix-shell --run "my command"
cabal install
``` ```
is equivalent to running `my command` from within a Nix shell.
Alternatively, if you want to run the command "from the outside", in your current shell: #### Disable optimization flags
``` Make a file `cabal.project.local` that will tell Cabal to turn off optimizations:
nix-shell --run "cabal update" ```shell
nix-shell --run "cabal install" cp cabal.project.local_toCopy cabal.project.local
``` ```
#### With Stack #### Install backend dependencies
Install [Stack (or Haskell Tool Stack)](https://docs.haskellstack.org/en/stable/): *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.*
```shell *This documentation shows how to build with cabal. For information related to stack, see `docs/using_stack.md`.*
curl -sSL https://get.haskellstack.org/ | sh
```
Verify the installation is complete with **From within the Nix shell**, run:
```shell ```shell
stack --version n$ cabal update
Version 2.9.1 n$ cabal install
``` ```
NOTE: Default build (with optimizations) requires large amounts of RAM (16GB at least). To avoid heavy compilation times and swapping out your machine, it is recommended to `stack build` with the `--fast` flag, i.e.: #### Build the backend and frontend
```shell ```shell
stack build --fast ./bin/install
cd purescript-gargantext/
./bin/install
cd ..
``` ```
### Initializing and running
#### Keeping the stack.yaml updated with the cabal.project #### Start containers for database and NLP software bricks
(Section for Developers using stack only)
Once you have a valid version of `stack`, building requires generating a valid `stack.yaml`.
This can be obtained by installing `cabal2stack`:
```shell ```shell
git clone https://github.com/iconnect/cabal2stack.git cd devops/docker
cd cabal2stack docker compose up
``` ```
Then, depending on what build system you are using, either build with `cabal install --overwrite-policy=always` or `stack install`. The initialization schema should be loaded automatically from `devops/postgres/schema.sql`.
And finally: #### Create configuration file
```shell ```shell
cabal2stack --system-ghc --allow-newer --resolver lts-21.17 --resolver-file devops/stack/lts-21.17.yaml -o stack.yaml
stack build
```
The good news is that you don't have to do all of this manually; during development, after modifying the
`cabal.project`, it's enough to do:
```shell
./bin/update-project-dependencies
```
## Initialization <a name="init"></a>
#### 1. Docker-compose will configure your database and some NLP bricks (such as CoreNLP):
First install docker-compose on your system and then:
``` sh
docker compose up
```
Initialization schema should be loaded automatically (from `devops/postgres/schema.sql`).
##### (Optional) If using stack, then install:
``` sh
stack install
```
#### 2. Copy the configuration file:
``` sh
cp gargantext.ini_toModify gargantext.ini cp gargantext.ini_toModify gargantext.ini
``` ```
> Do not worry, `.gitignore` avoids adding this file to the repository by mistake, then you can change the passwords in gargantext.ini safely.
#### 3. A user have to be created first as instance:
In your nix-shell
``` sh
gargantext-cli init --ini-path "gargantext.ini"
```
Now, `user1` is created with password `1resu`
#### 4. Clone FRONTEND repository: > `.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.
From the Backend root folder (haskell-gargantext): #### Create master user
From within the Nix shell:
```shell ```shell
git clone https://gitlab.iscpif.fr/gargantext/purescript-gargantext.git n$ gargantext-cli init --ini-path gargantext.ini
cd purescript-gargantext
./install
``` ```
&nbsp;
## Launch & develop GarganText <a name="launch"></a>
> **Note:** here, the method with Cabal is used as default The master user's name is automatically set to `gargantua`, but you will be prompted for their password and email address.
#### Running
From the Backend root folder (haskell-gargantext): From inside a Nix shell:
```shell
``` shell n$ cabal run gargantext-server -- --ini gargantext.ini --run Prod
./start
# The start script runs following commands:
# - `./bin/install` to update and build the project
# - `docker compose up` to run the Docker for postgresql from devops/docker folder
# - `cabal run gargantext-server -- --ini gargantext.ini --run Prod` to run other services through `nix-shell`
``` ```
For frontend development and compilation, see the [Frontend Readme.md](https://gitlab.iscpif.fr/gargantext/purescript-gargantext#dev) 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.
### Running tests ### Running tests
...@@ -391,7 +282,6 @@ Maybe you need to change the port to 5433 for database connection in your gargan ...@@ -391,7 +282,6 @@ Maybe you need to change the port to 5433 for database connection in your gargan
## `haskell-language-server` ## `haskell-language-server`
If you want to use `haskell-language-server` for GHC 9.4.7, install it If you want to use `haskell-language-server` for GHC 9.4.7, install it
......
...@@ -4,6 +4,7 @@ module CLI.Admin ( ...@@ -4,6 +4,7 @@ module CLI.Admin (
, adminCmd , adminCmd
) where ) where
import CLI.Parsers
import CLI.Types import CLI.Types
import Data.List.NonEmpty qualified as NE import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T import Data.Text qualified as T
...@@ -18,8 +19,8 @@ import Options.Applicative ...@@ -18,8 +19,8 @@ import Options.Applicative
import Prelude (String) import Prelude (String)
adminCLI :: AdminArgs -> IO () adminCLI :: AdminArgs -> IO ()
adminCLI (AdminArgs iniPath mails) = do adminCLI (AdminArgs iniPath settingsPath mails) = do
withDevEnv iniPath $ \env -> do withDevEnv iniPath settingsPath $ \env -> do
x <- runCmdDev env ((newUsers $ NE.map cs (NE.fromList mails)) :: Cmd'' DevEnv BackendInternalError (NonEmpty UserId)) x <- runCmdDev env ((newUsers $ NE.map cs (NE.fromList mails)) :: Cmd'' DevEnv BackendInternalError (NonEmpty UserId))
putStrLn (show x :: Text) putStrLn (show x :: Text)
...@@ -28,10 +29,7 @@ adminCmd = command "admin" (info (helper <*> fmap CLISub admin_p) (progDesc "Cre ...@@ -28,10 +29,7 @@ adminCmd = command "admin" (info (helper <*> fmap CLISub admin_p) (progDesc "Cre
admin_p :: Parser CLICmd admin_p :: Parser CLICmd
admin_p = fmap CCMD_admin $ AdminArgs admin_p = fmap CCMD_admin $ AdminArgs
<$> ( strOption ( long "ini-path" <$> ini_p <*> settings_p
<> metavar "FILEPATH"
<> help "Location of the .ini path"
) )
<*> ( option (maybeReader emails_p) ( long "emails" <*> ( option (maybeReader emails_p) ( long "emails"
<> metavar "email1,email2,..." <> metavar "email1,email2,..."
<> help "A comma-separated list of emails." <> help "A comma-separated list of emails."
......
...@@ -18,6 +18,7 @@ Import a corpus binary. ...@@ -18,6 +18,7 @@ Import a corpus binary.
module CLI.Import where module CLI.Import where
import CLI.Parsers
import CLI.Types import CLI.Types
import Gargantext.API.Admin.EnvTypes (DevEnv(..), DevJobHandle(..)) import Gargantext.API.Admin.EnvTypes (DevEnv(..), DevJobHandle(..))
import Gargantext.API.Dev (withDevEnv, runCmdGargDev) import Gargantext.API.Dev (withDevEnv, runCmdGargDev)
...@@ -26,6 +27,7 @@ import Gargantext.API.Node () -- instances ...@@ -26,6 +27,7 @@ import Gargantext.API.Node () -- instances
import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..)) import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..))
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Query
import Gargantext.Database.Action.Flow (flowCorpusFile, flowAnnuaire, TermType(..)) import Gargantext.Database.Action.Flow (flowCorpusFile, flowAnnuaire, TermType(..))
import Gargantext.Database.Action.Flow.Types (FlowCmdM) import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Admin.Types.Node (CorpusId) import Gargantext.Database.Admin.Types.Node (CorpusId)
...@@ -33,13 +35,12 @@ import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpu ...@@ -33,13 +35,12 @@ import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserNormalCorpu
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Utils.Jobs.Monad ( MonadJobStatus, JobHandle ) import Gargantext.Utils.Jobs.Monad ( MonadJobStatus, JobHandle )
import Options.Applicative import Options.Applicative
import qualified Data.Text as T
import Prelude (String) import Prelude (String)
import Gargantext.Core.Types.Query import qualified Data.Text as T
importCLI :: ImportArgs -> IO () importCLI :: ImportArgs -> IO ()
importCLI (ImportArgs fun user name iniPath limit corpusPath) = do importCLI (ImportArgs fun user name iniPath settingsPath limit corpusPath) = do
let let
tt = Multi EN tt = Multi EN
format = TsvGargV3 format = TsvGargV3
...@@ -53,7 +54,7 @@ importCLI (ImportArgs fun user name iniPath limit corpusPath) = do ...@@ -53,7 +54,7 @@ importCLI (ImportArgs fun user name iniPath limit corpusPath) = do
annuaire :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId annuaire :: forall m. (FlowCmdM DevEnv BackendInternalError m, MonadJobStatus m, JobHandle m ~ DevJobHandle) => m CorpusId
annuaire = flowAnnuaire (MkCorpusUserNormalCorpusName (UserName $ cs user) "Annuaire") (Multi EN) corpusPath DevJobHandle annuaire = flowAnnuaire (MkCorpusUserNormalCorpusName (UserName $ cs user) "Annuaire") (Multi EN) corpusPath DevJobHandle
withDevEnv iniPath $ \env -> do withDevEnv iniPath settingsPath $ \env -> do
void $ case fun of void $ case fun of
IF_corpus IF_corpus
-> runCmdGargDev env corpus -> runCmdGargDev env corpus
...@@ -75,8 +76,9 @@ import_p = fmap CCMD_import $ ImportArgs ...@@ -75,8 +76,9 @@ import_p = fmap CCMD_import $ ImportArgs
) ) ) )
<*> ( option str ( long "user") ) <*> ( option str ( long "user") )
<*> ( option str ( long "name") ) <*> ( option str ( long "name") )
<*> ( option str ( long "ini" <> help "Path to the .ini file.") ) <*> ini_p
<*> (fmap Limit ( option auto ( long "ini" <> metavar "INT" <> help "The limit for the query") )) <*> settings_p
<*> (fmap Limit ( option auto ( long "limit" <> metavar "INT" <> help "The limit for the query") ))
<*> ( option str ( long "corpus-path" <> help "Path to corpus file") ) <*> ( option str ( long "corpus-path" <> help "Path to corpus file") )
function_p :: String -> Either String ImportFunction function_p :: String -> Either String ImportFunction
......
...@@ -15,36 +15,38 @@ Initialise the Gargantext dataset. ...@@ -15,36 +15,38 @@ Initialise the Gargantext dataset.
module CLI.Init where module CLI.Init where
import CLI.Parsers
import CLI.Types
import Data.List.NonEmpty qualified as NE import Data.List.NonEmpty qualified as NE
import Gargantext.API.Admin.Settings
import Gargantext.API.Admin.Types
import Gargantext.API.Dev (withDevEnv, runCmdDev) import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Errors.Types import Gargantext.API.Errors.Types
import Gargantext.API.Node () -- instances only import Gargantext.API.Node () -- instances only
import Gargantext.Core.Config (GargConfig(..), readConfig)
import Gargantext.Core.Types.Individu (User(..), arbitraryNewUsers, NewUser(..), arbitraryUsername, GargPassword(..)) import Gargantext.Core.Types.Individu (User(..), arbitraryNewUsers, NewUser(..), arbitraryUsername, GargPassword(..))
import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMkRootWithCorpus) import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMkRootWithCorpus)
import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers) import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (DBCmd')
import Gargantext.Database.Prelude (DBCmd) import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Database.Query.Table.Node (getOrMkList) import Gargantext.Database.Query.Table.Node (getOrMkList)
import Gargantext.Database.Query.Table.User (insertNewUsers, ) import Gargantext.Database.Query.Table.User (insertNewUsers, )
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserMaster)) import Gargantext.Database.Query.Tree.Root (MkCorpusUser(MkCorpusUserMaster))
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Core.Config (GargConfig(..), readConfig)
import Gargantext.API.Admin.Types
import Gargantext.Database.Prelude (DBCmd')
import CLI.Types
import Options.Applicative import Options.Applicative
initCLI :: InitArgs -> IO () initCLI :: InitArgs -> IO ()
initCLI (InitArgs iniPath) = do initCLI (InitArgs iniPath settingsPath) = do
putStrLn ("Enter master user (gargantua) _password_ :" :: Text) putStrLn ("Enter master user (gargantua) _password_ :" :: Text)
password <- getLine password <- getLine
putStrLn ("Enter master user (gargantua) _email_ :" :: Text) putStrLn ("Enter master user (gargantua) _email_ :" :: Text)
email <- getLine email <- getLine
cfg <- readConfig iniPath cfg <- readConfig (_IniFile iniPath)
let secret = _gc_secretkey cfg let secret = _gc_secretkey cfg
let createUsers :: forall env. HasSettings env => DBCmd' env BackendInternalError Int64 let createUsers :: forall env. HasSettings env => DBCmd' env BackendInternalError Int64
...@@ -67,7 +69,7 @@ initCLI (InitArgs iniPath) = do ...@@ -67,7 +69,7 @@ initCLI (InitArgs iniPath) = do
_triggers <- initLastTriggers masterListId _triggers <- initLastTriggers masterListId
pure (masterUserId, masterRootId, masterCorpusId, masterListId) pure (masterUserId, masterRootId, masterCorpusId, masterListId)
withDevEnv iniPath $ \env -> do withDevEnv iniPath settingsPath $ \env -> do
_ <- runCmdDev env (initFirstTriggers secret :: DBCmd BackendInternalError [Int64]) _ <- runCmdDev env (initFirstTriggers secret :: DBCmd BackendInternalError [Int64])
_ <- runCmdDev env createUsers _ <- runCmdDev env createUsers
x <- runCmdDev env initMaster x <- runCmdDev env initMaster
...@@ -79,7 +81,4 @@ initCmd = command "init" (info (helper <*> fmap CLISub init_p) (progDesc "Initia ...@@ -79,7 +81,4 @@ initCmd = command "init" (info (helper <*> fmap CLISub init_p) (progDesc "Initia
init_p :: Parser CLICmd init_p :: Parser CLICmd
init_p = fmap CCMD_init $ InitArgs init_p = fmap CCMD_init $ InitArgs
<$> ( strOption ( long "ini-path" <$> ini_p <*> settings_p
<> metavar "FILEPATH"
<> help "Location of the .ini path"
) )
...@@ -14,7 +14,9 @@ Portability : POSIX ...@@ -14,7 +14,9 @@ Portability : POSIX
module CLI.Invitations where module CLI.Invitations where
import CLI.Parsers
import CLI.Types import CLI.Types
import Gargantext.API.Admin.Settings
import Gargantext.API.Admin.Types import Gargantext.API.Admin.Types
import Gargantext.API.Dev (withDevEnv, runCmdDev) import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Errors.Types import Gargantext.API.Errors.Types
...@@ -22,18 +24,18 @@ import Gargantext.API.Node () -- instances only ...@@ -22,18 +24,18 @@ import Gargantext.API.Node () -- instances only
import Gargantext.API.Node.Share qualified as Share import Gargantext.API.Node.Share qualified as Share
import Gargantext.API.Node.Share.Types qualified as Share import Gargantext.API.Node.Share.Types qualified as Share
import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CET
import Gargantext.Core.Config (readConfig)
import Gargantext.Core.NLP (HasNLPServer) import Gargantext.Core.NLP (HasNLPServer)
import Gargantext.Core.Types
import Gargantext.Core.Types.Individu (User(..)) import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Prelude (CmdRandom) import Gargantext.Database.Prelude (CmdRandom)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Core.Config (readConfig)
import Options.Applicative import Options.Applicative
import Prelude (String) import Prelude (String)
import Gargantext.Core.Types
invitationsCLI :: InvitationsArgs -> IO () invitationsCLI :: InvitationsArgs -> IO ()
invitationsCLI (InvitationsArgs iniPath user node_id email) = do invitationsCLI (InvitationsArgs iniPath settingsPath user node_id email) = do
_cfg <- readConfig iniPath _cfg <- readConfig (_IniFile iniPath)
let invite :: ( HasSettings env let invite :: ( HasSettings env
, CmdRandom env BackendInternalError m , CmdRandom env BackendInternalError m
...@@ -41,7 +43,7 @@ invitationsCLI (InvitationsArgs iniPath user node_id email) = do ...@@ -41,7 +43,7 @@ invitationsCLI (InvitationsArgs iniPath user node_id email) = do
, CET.HasCentralExchangeNotification env ) => m Int , CET.HasCentralExchangeNotification env ) => m Int
invite = Share.api (UserName $ cs user) node_id (Share.ShareTeamParams $ cs email) invite = Share.api (UserName $ cs user) node_id (Share.ShareTeamParams $ cs email)
withDevEnv iniPath $ \env -> do withDevEnv iniPath settingsPath $ \env -> do
void $ runCmdDev env invite void $ runCmdDev env invite
invitationsCmd :: HasCallStack => Mod CommandFields CLI invitationsCmd :: HasCallStack => Mod CommandFields CLI
...@@ -49,10 +51,8 @@ invitationsCmd = command "invitations" (info (helper <*> fmap CLISub invitations ...@@ -49,10 +51,8 @@ invitationsCmd = command "invitations" (info (helper <*> fmap CLISub invitations
invitations_p :: Parser CLICmd invitations_p :: Parser CLICmd
invitations_p = fmap CCMD_invitations $ InvitationsArgs invitations_p = fmap CCMD_invitations $ InvitationsArgs
<$> ( strOption ( long "ini-path" <$> ini_p
<> metavar "FILEPATH" <*> settings_p
<> help "Location of the .ini path"
) )
<*> ( strOption ( long "user" ) ) <*> ( strOption ( long "user" ) )
<*> ( option (eitherReader node_p) ( long "node-id" <> metavar "POSITIVE-INT" <> help "The node ID.") ) <*> ( option (eitherReader node_p) ( long "node-id" <> metavar "POSITIVE-INT" <> help "The node ID.") )
<*> ( strOption ( long "email" <> help "The email address.") ) <*> ( strOption ( long "email" <> help "The email address.") )
......
{-| Common parsers for the CLI. -}
module CLI.Parsers where
import Prelude
import Gargantext.API.Admin.Settings
import Options.Applicative
ini_p :: Parser IniFile
ini_p = maybe (IniFile "gargantext.ini") IniFile <$>
optional ( strOption ( long "ini-path"
<> metavar "FILEPATH"
<> help "Location of the .ini file"
) )
settings_p :: Parser SettingsFile
settings_p = maybe (SettingsFile "gargantext-settings.toml") SettingsFile <$>
optional ( strOption ( long "settings-path"
<> metavar "FILEPATH"
<> help "Location of the gargantext-settings toml file"
) )
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module CLI.Server.Routes (
routesCLI
, routesCmd
) where
import CLI.Types
import Data.Aeson.Encode.Pretty
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as BL
import Gargantext.API.Routes.Named
import Options.Applicative
import Prelude
import Servant.API
import Servant.API.Routes
import Servant.Auth qualified as Servant
routesCmd :: Mod CommandFields CLI
routesCmd = command "routes" (info (helper <*> (fmap CLISub $ fmap CCMD_routes routesParser))
(progDesc "Server routes related commands."))
routesParser :: Parser CLIRoutes
routesParser = hsubparser (
(command "list" (info (helper <*> list_p)
(progDesc "List all the available routes, computed by the Routes types."))) <>
(command "export" (info (helper <*> export_p)
(progDesc "Exports all the routes into a file, for golden-diff testing.")))
)
list_p :: Parser CLIRoutes
list_p = pure CLIR_list
export_p :: Parser CLIRoutes
export_p = CLIR_export <$>
strOption ( long "file" <> metavar "output.json" <> help "Export the routes to a file." )
instance HasRoutes api => HasRoutes (Servant.Auth xs a :> api) where
getRoutes = getRoutes @api
instance HasRoutes Raw where
getRoutes = []
routesCLI :: CLIRoutes -> IO ()
routesCLI = \case
CLIR_list
-> printRoutes @(NamedRoutes API)
(CLIR_export filePath)
-> B.writeFile filePath . BL.toStrict $ encodePretty (getRoutes @(NamedRoutes API))
...@@ -3,9 +3,10 @@ module CLI.Types where ...@@ -3,9 +3,10 @@ module CLI.Types where
import Data.String import Data.String
import Data.Text (Text) import Data.Text (Text)
import Gargantext.API.Admin.Settings
import Gargantext.Core.Types (NodeId)
import Gargantext.Core.Types.Query import Gargantext.Core.Types.Query
import Prelude import Prelude
import Gargantext.Core.Types (NodeId)
newtype CorpusFile = CorpusFile { _CorpusFile :: FilePath } newtype CorpusFile = CorpusFile { _CorpusFile :: FilePath }
deriving (Show, Eq, IsString) deriving (Show, Eq, IsString)
...@@ -25,8 +26,9 @@ data ObfuscateDBArgs = ObfuscateDBArgs { ...@@ -25,8 +26,9 @@ data ObfuscateDBArgs = ObfuscateDBArgs {
} deriving (Show, Eq) } deriving (Show, Eq)
data AdminArgs = AdminArgs data AdminArgs = AdminArgs
{ iniPath :: !FilePath { iniPath :: !IniFile
, emails :: [String] , settingsPath :: !SettingsFile
, emails :: [String]
} deriving (Show, Eq) } deriving (Show, Eq)
data ImportFunction data ImportFunction
...@@ -39,17 +41,20 @@ data ImportArgs = ImportArgs ...@@ -39,17 +41,20 @@ data ImportArgs = ImportArgs
{ imp_function :: !ImportFunction { imp_function :: !ImportFunction
, imp_user :: !Text , imp_user :: !Text
, imp_name :: !Text , imp_name :: !Text
, imp_ini :: !FilePath , imp_ini :: !IniFile
, imp_settings :: !SettingsFile
, imp_limit :: !Limit , imp_limit :: !Limit
, imp_corpus_path :: !FilePath , imp_corpus_path :: !FilePath
} deriving (Show, Eq) } deriving (Show, Eq)
data InitArgs = InitArgs data InitArgs = InitArgs
{ init_ini :: !FilePath { init_ini :: !IniFile
, init_settings :: !SettingsFile
} deriving (Show, Eq) } deriving (Show, Eq)
data InvitationsArgs = InvitationsArgs data InvitationsArgs = InvitationsArgs
{ inv_path :: !FilePath { inv_path :: !IniFile
, inv_settings :: !SettingsFile
, inv_user :: !Text , inv_user :: !Text
, inv_node_id :: !NodeId , inv_node_id :: !NodeId
, inv_email :: !Text , inv_email :: !Text
...@@ -60,7 +65,8 @@ data PhyloArgs = PhyloArgs ...@@ -60,7 +65,8 @@ data PhyloArgs = PhyloArgs
} deriving (Show, Eq) } deriving (Show, Eq)
data UpgradeArgs = UpgradeArgs data UpgradeArgs = UpgradeArgs
{ upgrade_ini :: !FilePath { upgrade_ini :: !IniFile
, upgrade_settings :: !SettingsFile
} deriving (Show, Eq) } deriving (Show, Eq)
data GoldenFileDiffArgs = GoldenFileDiffArgs data GoldenFileDiffArgs = GoldenFileDiffArgs
...@@ -68,6 +74,11 @@ data GoldenFileDiffArgs = GoldenFileDiffArgs ...@@ -68,6 +74,11 @@ data GoldenFileDiffArgs = GoldenFileDiffArgs
, gdf_actual :: !FilePath , gdf_actual :: !FilePath
} deriving (Show, Eq) } deriving (Show, Eq)
data CLIRoutes
= CLIR_list
| CLIR_export FilePath
deriving (Show, Eq)
data CLICmd data CLICmd
= CCMD_clean_csv_corpus = CCMD_clean_csv_corpus
| CCMD_filter_terms_and_cooc !CorpusFile !TermListFile !OutputFile | CCMD_filter_terms_and_cooc !CorpusFile !TermListFile !OutputFile
...@@ -80,6 +91,7 @@ data CLICmd ...@@ -80,6 +91,7 @@ data CLICmd
| CCMD_phylo_profile | CCMD_phylo_profile
| CCMD_upgrade !UpgradeArgs | CCMD_upgrade !UpgradeArgs
| CCMD_golden_file_diff !GoldenFileDiffArgs | CCMD_golden_file_diff !GoldenFileDiffArgs
| CCMD_routes !CLIRoutes
deriving (Show, Eq) deriving (Show, Eq)
data CLI = data CLI =
......
...@@ -17,16 +17,18 @@ Upgrade a gargantext node. ...@@ -17,16 +17,18 @@ Upgrade a gargantext node.
module CLI.Upgrade where module CLI.Upgrade where
import CLI.Types import CLI.Types
import CLI.Parsers
import Data.List qualified as List (cycle, concat, take, unlines) import Data.List qualified as List (cycle, concat, take, unlines)
import Gargantext.API.Admin.Settings
import Gargantext.API.Dev (withDevEnv) import Gargantext.API.Dev (withDevEnv)
import Gargantext.API.Node () -- instances only import Gargantext.API.Node () -- instances only
import Gargantext.Prelude
import Gargantext.Core.Config (GargConfig(..), readConfig) import Gargantext.Core.Config (GargConfig(..), readConfig)
import Prelude qualified import Gargantext.Prelude
import Options.Applicative import Options.Applicative
import Prelude qualified
upgradeCLI :: UpgradeArgs -> IO () upgradeCLI :: UpgradeArgs -> IO ()
upgradeCLI (UpgradeArgs iniPath) = do upgradeCLI (UpgradeArgs iniPath settingsFile) = do
let ___ = putStrLn ((List.concat let ___ = putStrLn ((List.concat
$ List.take 72 $ List.take 72
...@@ -45,10 +47,10 @@ upgradeCLI (UpgradeArgs iniPath) = do ...@@ -45,10 +47,10 @@ upgradeCLI (UpgradeArgs iniPath) = do
_ok <- getLine _ok <- getLine
cfg <- readConfig iniPath cfg <- readConfig (_IniFile iniPath)
let _secret = _gc_secretkey cfg let _secret = _gc_secretkey cfg
withDevEnv iniPath $ \_env -> do withDevEnv iniPath settingsFile $ \_env -> do
-- _ <- runCmdDev env addIndex -- _ <- runCmdDev env addIndex
-- _ <- runCmdDev env refreshIndex -- _ <- runCmdDev env refreshIndex
...@@ -95,7 +97,5 @@ upgradeCmd = command "upgrade" (info (helper <*> fmap CLISub upgrade_p) (progDes ...@@ -95,7 +97,5 @@ upgradeCmd = command "upgrade" (info (helper <*> fmap CLISub upgrade_p) (progDes
upgrade_p :: Parser CLICmd upgrade_p :: Parser CLICmd
upgrade_p = fmap CCMD_upgrade $ UpgradeArgs upgrade_p = fmap CCMD_upgrade $ UpgradeArgs
<$> ( strOption ( long "ini-path" <$> ini_p
<> metavar "FILEPATH" <*> settings_p
<> help "Location of the .ini path"
) )
...@@ -24,13 +24,14 @@ import CLI.ObfuscateDB (obfuscateDB, obfuscateDBCmd) ...@@ -24,13 +24,14 @@ import CLI.ObfuscateDB (obfuscateDB, obfuscateDBCmd)
import CLI.Types import CLI.Types
import Options.Applicative import Options.Applicative
import CLI.Admin (adminCLI, adminCmd) import CLI.Admin (adminCLI, adminCmd)
import CLI.FileDiff (fileDiffCLI, fileDiffCmd)
import CLI.Import (importCLI, importCmd) import CLI.Import (importCLI, importCmd)
import CLI.Init (initCLI, initCmd) import CLI.Init (initCLI, initCmd)
import CLI.Invitations (invitationsCLI, invitationsCmd) import CLI.Invitations (invitationsCLI, invitationsCmd)
import CLI.Phylo (phyloCLI, phyloCmd) import CLI.Phylo (phyloCLI, phyloCmd)
import CLI.Phylo.Profile (phyloProfileCLI, phyloProfileCmd) import CLI.Phylo.Profile (phyloProfileCLI, phyloProfileCmd)
import CLI.Server.Routes (routesCLI, routesCmd)
import CLI.Upgrade (upgradeCLI, upgradeCmd) import CLI.Upgrade (upgradeCLI, upgradeCmd)
import CLI.FileDiff (fileDiffCLI, fileDiffCmd)
runCLI :: CLI -> IO () runCLI :: CLI -> IO ()
runCLI = \case runCLI = \case
...@@ -56,6 +57,9 @@ runCLI = \case ...@@ -56,6 +57,9 @@ runCLI = \case
-> upgradeCLI args -> upgradeCLI args
CLISub (CCMD_golden_file_diff args) CLISub (CCMD_golden_file_diff args)
-> fileDiffCLI args -> fileDiffCLI args
CLISub (CCMD_routes args)
-> routesCLI args
main :: IO () main :: IO ()
main = runCLI =<< execParser opts main = runCLI =<< execParser opts
...@@ -76,5 +80,6 @@ allOptions = subparser ( ...@@ -76,5 +80,6 @@ allOptions = subparser (
phyloCmd <> phyloCmd <>
phyloProfileCmd <> phyloProfileCmd <>
upgradeCmd <> upgradeCmd <>
fileDiffCmd fileDiffCmd <>
routesCmd
) )
...@@ -24,12 +24,14 @@ module Main where ...@@ -24,12 +24,14 @@ module Main where
import Data.Text (unpack) import Data.Text (unpack)
import Data.Version (showVersion) import Data.Version (showVersion)
import GHC.IO.Encoding
import Gargantext.API (startGargantext) -- , startGargantextMock) import Gargantext.API (startGargantext) -- , startGargantextMock)
import Gargantext.API.Admin.EnvTypes import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Settings
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.System.Logging import Gargantext.System.Logging
import GHC.IO.Encoding
import Options.Generic import Options.Generic
import Prelude (String)
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import qualified Paths_gargantext as PG -- cabal magic build module import qualified Paths_gargantext as PG -- cabal magic build module
...@@ -45,6 +47,8 @@ data MyOptions w = ...@@ -45,6 +47,8 @@ data MyOptions w =
<?> "By default: 8008" <?> "By default: 8008"
, ini :: w ::: Maybe Text , ini :: w ::: Maybe Text
<?> "Ini-file path of gargantext.ini" <?> "Ini-file path of gargantext.ini"
, settings :: w ::: Maybe String
<?> "By default: gargantext-settings.toml"
, version :: w ::: Bool , version :: w ::: Bool
<?> "Show version number and exit" <?> "Show version number and exit"
} }
...@@ -60,7 +64,7 @@ main = withLogger () $ \ioLogger -> do ...@@ -60,7 +64,7 @@ main = withLogger () $ \ioLogger -> do
setLocaleEncoding utf8 setLocaleEncoding utf8
currentLocale <- getLocaleEncoding currentLocale <- getLocaleEncoding
MyOptions myMode myPort myIniFile myVersion <- unwrapRecord MyOptions myMode myPort myIniFile mb_settingsFile myVersion <- unwrapRecord
"Gargantext server" "Gargantext server"
--------------------------------------------------------------- ---------------------------------------------------------------
if myVersion then do if myVersion then do
...@@ -75,12 +79,16 @@ main = withLogger () $ \ioLogger -> do ...@@ -75,12 +79,16 @@ main = withLogger () $ \ioLogger -> do
myIniFile' = case myIniFile of myIniFile' = case myIniFile of
Nothing -> panicTrace "[ERROR] gargantext.ini needed" Nothing -> panicTrace "[ERROR] gargantext.ini needed"
Just i -> IniFile $ unpack i
settingsFile = SettingsFile $ case mb_settingsFile of
Nothing -> "gargantext-settings.toml"
Just i -> i Just i -> i
--------------------------------------------------------------- ---------------------------------------------------------------
let start = case myMode of let start = case myMode of
Mock -> panicTrace "[ERROR] Mock mode unsupported" Mock -> panicTrace "[ERROR] Mock mode unsupported"
_ -> startGargantext myMode myPort' (unpack myIniFile') _ -> startGargantext myMode myPort' myIniFile' settingsFile
logMsg ioLogger INFO $ "Starting with " <> show myMode <> " mode." logMsg ioLogger INFO $ "Starting with " <> show myMode <> " mode."
logMsg ioLogger INFO $ "Machine locale: " <> show currentLocale logMsg ioLogger INFO $ "Machine locale: " <> show currentLocale
start start
......
...@@ -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="e1739caac7fc663496c2cd55f9068a7c52c3cbaae389a49aa961f962ed8439f4" expected_cabal_project_hash="eccf547470d723a7dbd9e5bc271f1925f9f6e2cf9092f367275bde3657b3c2cf"
expected_cabal_project_freeze_hash="6a2e5baca97c36d2ed2f398de43df393763ee01bbd676a50da89067b8f830fe9" expected_cabal_project_freeze_hash="db651e03c16a9bbc4493bbd3d6244d7196b72a0e39f3245a1734742b89a037ce"
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
......
...@@ -180,6 +180,11 @@ source-repository-package ...@@ -180,6 +180,11 @@ source-repository-package
location: https://github.com/adinapoli/http-reverse-proxy.git location: https://github.com/adinapoli/http-reverse-proxy.git
tag: c90b7bc55b0e628d0b71ccee4e222833a19792f8 tag: c90b7bc55b0e628d0b71ccee4e222833a19792f8
source-repository-package
type: git
location: https://github.com/fpringle/servant-routes.git
tag: 7694f62af6bc1596d754b42af16da131ac403b3a
allow-older: * allow-older: *
allow-newer: * allow-newer: *
......
...@@ -351,6 +351,7 @@ constraints: any.Cabal ==3.8.1.0, ...@@ -351,6 +351,7 @@ constraints: any.Cabal ==3.8.1.0,
any.memory ==0.18.0, any.memory ==0.18.0,
memory +support_bytestring +support_deepseq, memory +support_bytestring +support_deepseq,
any.microlens ==0.4.13.1, any.microlens ==0.4.13.1,
any.microlens-th ==0.4.3.14,
any.microstache ==1.0.2.3, any.microstache ==1.0.2.3,
any.mime-mail ==0.5.1, any.mime-mail ==0.5.1,
any.mime-types ==0.1.2.0, any.mime-types ==0.1.2.0,
...@@ -508,6 +509,7 @@ constraints: any.Cabal ==3.8.1.0, ...@@ -508,6 +509,7 @@ constraints: any.Cabal ==3.8.1.0,
any.servant-job ==0.2.0.0, any.servant-job ==0.2.0.0,
any.servant-multipart ==0.12.1, any.servant-multipart ==0.12.1,
any.servant-multipart-api ==0.12.1, any.servant-multipart-api ==0.12.1,
any.servant-routes ==0.1.0.0,
any.servant-server ==0.20, any.servant-server ==0.20,
any.servant-swagger ==1.2, any.servant-swagger ==1.2,
any.servant-swagger-ui ==0.3.5.5.0.0, any.servant-swagger-ui ==0.3.5.5.0.0,
......
package gargantext
ghc-options: -fwrite-ide-info -hiedir=".stack-work/hiedb" -O0
package gargantext-admin
ghc-options: -O0
package gargantext-cli
ghc-options: -O0
package gargantext-db-obfuscation
ghc-options: -O0
package gargantext-import
ghc-options: -O0
package gargantext-init
ghc-options: -O0
package gargantext-invitations
ghc-options: -O0
package gargantext-phylo
ghc-options: -O0
package gargantext-server
ghc-options: -O0
package gargantext-upgrade
ghc-options: -O0
package gargantext-graph
ghc-options: -O0
package hmatrix
ghc-options: -O0
package sparse-linear
ghc-options: -O0
# Building Gargantext using the Stack tool
Those are the instructions for developers who wish to build Gargantext using stack instead of cabal.
## Prerequisites
You need [Stack](https://docs.haskellstack.org/en/stable/) (obviously). You can install it with:
```shell
curl -sSL https://get.haskellstack.org/ | sh
```
Check that the installation is complete with:
```shell
stack --version
Version 2.9.1
```
## Building and setting up
To build with stack, follow the instructions in `README.md`, with the following changes:
- Replace the `cabal update` and `cabal install` commands with (still from within a Nix shell!):
```shell
stack build --fast
```
*Note: The default build (with optimizations) requires large amounts of RAM (16GB at least). The (recommended) `--fast` flag is here to avoid heavy compilation times and swapping out your machine; just omit it if you want to build with optimizations.*
- After you have run the `docker compose up` command, install with
```shell
stack install
```
## Keeping the stack.yaml updated with the cabal.project
Once you have a valid version of stack, building requires generating a valid `stack.yaml`. This can be obtained by installing `cabal2stack`:
```shell
git clone https://github.com/iconnect/cabal2stack.git
cd cabal2stack
```
Then, depending on what build system you are using, either build with `cabal install --overwrite-policy=always` or `stack install`.
And finally:
```shell
cabal2stack --system-ghc --allow-newer --resolver lts-21.17 --resolver-file devops/stack/lts-21.17.yaml -o stack.yaml
stack build
```
The good news is you don't have to do all of this manually; during development, after modifying `cabal.project`, it's enough to run:
```shell
./bin/update-project-dependencies
```
...@@ -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.8 version: 0.0.7.1.9
synopsis: Search, map, share synopsis: Search, map, share
description: Please see README.md description: Please see README.md
category: Data category: Data
...@@ -49,6 +49,7 @@ data-files: ...@@ -49,6 +49,7 @@ data-files:
test-data/phylo/phylo2dot2json.golden.json test-data/phylo/phylo2dot2json.golden.json
test-data/stemming/lancaster.txt test-data/stemming/lancaster.txt
test-data/test_config.ini test-data/test_config.ini
test-data/gargantext-settings.toml
gargantext-settings.toml gargantext-settings.toml
.clippy.dhall .clippy.dhall
...@@ -660,6 +661,7 @@ library ...@@ -660,6 +661,7 @@ library
, servant-flatten ^>= 0.2 , servant-flatten ^>= 0.2
, servant-job >= 0.2.0.0 , servant-job >= 0.2.0.0
, servant-multipart ^>= 0.12.1 , servant-multipart ^>= 0.12.1
, servant-routes < 0.2
, servant-server >= 0.18.3 && < 0.20 , servant-server >= 0.18.3 && < 0.20
, servant-swagger >= 1.2 , servant-swagger >= 1.2
, servant-swagger-ui ^>= 0.3.5.3.5.0 , servant-swagger-ui ^>= 0.3.5.3.5.0
...@@ -726,9 +728,11 @@ executable gargantext-cli ...@@ -726,9 +728,11 @@ executable gargantext-cli
CLI.Init CLI.Init
CLI.Invitations CLI.Invitations
CLI.ObfuscateDB CLI.ObfuscateDB
CLI.Parsers
CLI.Phylo CLI.Phylo
CLI.Phylo.Common CLI.Phylo.Common
CLI.Phylo.Profile CLI.Phylo.Profile
CLI.Server.Routes
CLI.Types CLI.Types
CLI.Upgrade CLI.Upgrade
CLI.Utils CLI.Utils
...@@ -737,6 +741,7 @@ executable gargantext-cli ...@@ -737,6 +741,7 @@ executable gargantext-cli
bin/gargantext-cli bin/gargantext-cli
build-depends: build-depends:
aeson ^>= 1.5.6.0 aeson ^>= 1.5.6.0
, aeson-pretty
, async ^>= 2.2.4 , async ^>= 2.2.4
, bytestring ^>= 0.10.12.0 , bytestring ^>= 0.10.12.0
, cassava ^>= 0.5.2.0 , cassava ^>= 0.5.2.0
...@@ -753,6 +758,9 @@ executable gargantext-cli ...@@ -753,6 +758,9 @@ executable gargantext-cli
, parallel ^>= 3.2.2.0 , parallel ^>= 3.2.2.0
, postgresql-simple ^>= 0.6.4 , postgresql-simple ^>= 0.6.4
, protolude ^>= 0.3.3 , protolude ^>= 0.3.3
, servant
, servant-auth
, servant-routes < 0.2
, shelly , shelly
, split ^>= 0.2.3.4 , split ^>= 0.2.3.4
, text ^>= 1.2.4.1 , text ^>= 1.2.4.1
...@@ -843,6 +851,7 @@ test-suite garg-test-tasty ...@@ -843,6 +851,7 @@ test-suite garg-test-tasty
Test.Parsers.Date Test.Parsers.Date
Test.Parsers.Types Test.Parsers.Types
Test.Parsers.WOS Test.Parsers.WOS
Test.Server.ReverseProxy
Test.Types Test.Types
Test.Utils Test.Utils
Test.Utils.Crypto Test.Utils.Crypto
...@@ -906,6 +915,7 @@ test-suite garg-test-tasty ...@@ -906,6 +915,7 @@ test-suite garg-test-tasty
, servant-websockets >= 2.0.0 && < 2.1 , servant-websockets >= 2.0.0 && < 2.1
, shelly >= 1.9 && < 2 , shelly >= 1.9 && < 2
, stm ^>= 2.5.0.1 , stm ^>= 2.5.0.1
, streaming-commons
, split , split
, tasty ^>= 1.4.2.1 , tasty ^>= 1.4.2.1
, tasty-golden , tasty-golden
...@@ -920,6 +930,7 @@ test-suite garg-test-tasty ...@@ -920,6 +930,7 @@ test-suite garg-test-tasty
, tree-diff , tree-diff
, unordered-containers ^>= 0.2.16.0 , unordered-containers ^>= 0.2.16.0
, unicode-collation >= 0.1.3.6 , unicode-collation >= 0.1.3.6
, unliftio
, validity ^>= 0.11.0.1 , validity ^>= 0.11.0.1
, vector ^>= 0.12.3.0 , vector ^>= 0.12.3.0
, wai , wai
...@@ -932,6 +943,7 @@ test-suite garg-test-hspec ...@@ -932,6 +943,7 @@ test-suite garg-test-hspec
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:
Paths_gargantext
Test.API Test.API
Test.API.Authentication Test.API.Authentication
Test.API.Errors Test.API.Errors
...@@ -946,9 +958,9 @@ test-suite garg-test-hspec ...@@ -946,9 +958,9 @@ test-suite garg-test-hspec
Test.Database.Operations.NodeStory Test.Database.Operations.NodeStory
Test.Database.Setup Test.Database.Setup
Test.Database.Types Test.Database.Types
Test.Utils Test.Server.ReverseProxy
Test.Types Test.Types
Paths_gargantext Test.Utils
hs-source-dirs: hs-source-dirs:
test test
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
...@@ -1001,6 +1013,7 @@ test-suite garg-test-hspec ...@@ -1001,6 +1013,7 @@ test-suite garg-test-hspec
, servant-websockets >= 2.0.0 && < 2.1 , servant-websockets >= 2.0.0 && < 2.1
, shelly >= 1.9 && < 2 , shelly >= 1.9 && < 2
, stm ^>= 2.5.0.1 , stm ^>= 2.5.0.1
, streaming-commons
, tasty ^>= 1.4.2.1 , tasty ^>= 1.4.2.1
, tasty-hspec , tasty-hspec
, tasty-hunit , tasty-hunit
...@@ -1011,6 +1024,7 @@ test-suite garg-test-hspec ...@@ -1011,6 +1024,7 @@ test-suite garg-test-hspec
, 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
, unliftio
, unordered-containers ^>= 0.2.16.0 , unordered-containers ^>= 0.2.16.0
, validity ^>= 0.11.0.1 , validity ^>= 0.11.0.1
, wai , wai
......
...@@ -44,7 +44,7 @@ import Data.Text.IO (putStrLn) ...@@ -44,7 +44,7 @@ import Data.Text.IO (putStrLn)
import Data.Validity import Data.Validity
import Gargantext.API.Admin.Auth.Types (AuthContext) import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.EnvTypes (Env, Mode(..)) import Gargantext.API.Admin.EnvTypes (Env, Mode(..))
import Gargantext.API.Admin.Settings (newEnv) import Gargantext.API.Admin.Settings (newEnv, IniFile(..), SettingsFile)
import Gargantext.API.Admin.Settings.CORS import Gargantext.API.Admin.Settings.CORS
import Gargantext.API.Admin.Settings.MicroServices import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings, microservicesSettings) import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings, corsSettings, microservicesSettings)
...@@ -69,9 +69,9 @@ import System.Cron.Schedule qualified as Cron ...@@ -69,9 +69,9 @@ import System.Cron.Schedule qualified as Cron
-- import System.FilePath -- import System.FilePath
-- | startGargantext takes as parameters port number and Ini file. -- | startGargantext takes as parameters port number and Ini file.
startGargantext :: Mode -> PortNumber -> FilePath -> IO () startGargantext :: Mode -> PortNumber -> IniFile -> SettingsFile -> IO ()
startGargantext mode port file = withLoggerHoisted mode $ \logger -> do startGargantext mode port iniFile settingsFile = withLoggerHoisted mode $ \logger -> do
env <- newEnv logger port file env <- newEnv logger port iniFile settingsFile
let proxyPort = env ^. settings.microservicesSettings.msProxyPort let proxyPort = env ^. settings.microservicesSettings.msProxyPort
runDbCheck env runDbCheck env
portRouteInfo port proxyPort portRouteInfo port proxyPort
...@@ -90,7 +90,7 @@ startGargantext mode port file = withLoggerHoisted mode $ \logger -> do ...@@ -90,7 +90,7 @@ startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
case r of case r of
Right True -> pure () Right True -> pure ()
_ -> panicTrace $ _ -> panicTrace $
"You must run 'gargantext-init " <> pack file <> "You must run 'gargantext-init " <> pack (_IniFile iniFile) <>
"' before running gargantext-server (only the first time)." "' before running gargantext-server (only the first time)."
portRouteInfo :: PortNumber -> PortNumber -> IO () portRouteInfo :: PortNumber -> PortNumber -> IO ()
......
...@@ -54,12 +54,21 @@ import System.IO (hClose) ...@@ -54,12 +54,21 @@ import System.IO (hClose)
import System.IO.Temp (withTempFile) import System.IO.Temp (withTempFile)
devSettings :: FilePath -> IO Settings newtype JwkFile = JwkFile { _JwkFile :: FilePath }
devSettings jwkFile = do deriving (Show, Eq, IsString)
newtype SettingsFile = SettingsFile { _SettingsFile :: FilePath }
deriving (Show, Eq, IsString)
newtype IniFile = IniFile { _IniFile :: FilePath }
deriving (Show, Eq, IsString)
devSettings :: JwkFile -> SettingsFile -> IO Settings
devSettings (JwkFile jwkFile) (SettingsFile settingsFile) = do
jwkExists <- doesFileExist jwkFile jwkExists <- doesFileExist jwkFile
when (not jwkExists) $ writeKey jwkFile when (not jwkExists) $ writeKey jwkFile
jwk <- readKey jwkFile jwk <- readKey jwkFile
GargTomlSettings{..} <- loadGargTomlSettings GargTomlSettings{..} <- loadGargTomlSettings settingsFile
pure $ Settings pure $ Settings
{ _corsSettings = _gargCorsSettings { _corsSettings = _gargCorsSettings
, _microservicesSettings = _gargMicroServicesSettings , _microservicesSettings = _gargMicroServicesSettings
...@@ -173,13 +182,13 @@ readRepoEnv repoDir = do ...@@ -173,13 +182,13 @@ readRepoEnv repoDir = do
pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock } pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
--} --}
devJwkFile :: FilePath devJwkFile :: JwkFile
devJwkFile = "dev.jwk" devJwkFile = JwkFile "dev.jwk"
newEnv :: Logger (GargM Env BackendInternalError) -> PortNumber -> FilePath -> IO Env newEnv :: Logger (GargM Env BackendInternalError) -> PortNumber -> IniFile -> SettingsFile -> IO Env
newEnv logger port file = do newEnv logger port (IniFile file) settingsFile = do
!manager_env <- newTlsManager !manager_env <- newTlsManager
!settings' <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file' !settings' <- devSettings devJwkFile settingsFile <&> appPort .~ port -- TODO read from 'file'
when (port /= settings' ^. appPort) $ when (port /= settings' ^. appPort) $
panicTrace "TODO: conflicting settings of port" panicTrace "TODO: conflicting settings of port"
......
...@@ -7,7 +7,6 @@ import Gargantext.API.Admin.Settings.CORS ...@@ -7,7 +7,6 @@ import Gargantext.API.Admin.Settings.CORS
import Gargantext.API.Admin.Settings.MicroServices import Gargantext.API.Admin.Settings.MicroServices
import Gargantext.Prelude (panicTrace) import Gargantext.Prelude (panicTrace)
import Gargantext.System.Logging import Gargantext.System.Logging
import Paths_gargantext
import Prelude import Prelude
import Toml import Toml
import Servant.Client.Core.BaseUrl import Servant.Client.Core.BaseUrl
...@@ -40,9 +39,8 @@ addProxyToAllowedOrigins stgs = ...@@ -40,9 +39,8 @@ addProxyToAllowedOrigins stgs =
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.
loadGargTomlSettings :: IO GargTomlSettings loadGargTomlSettings :: FilePath -> IO GargTomlSettings
loadGargTomlSettings = do loadGargTomlSettings tomlFile = do
tomlFile <- getDataFileName "gargantext-settings.toml"
tomlRes <- Toml.decodeFileEither settingsCodec tomlFile tomlRes <- Toml.decodeFileEither settingsCodec tomlFile
case tomlRes of case tomlRes of
Left errs -> do Left errs -> do
......
...@@ -2,6 +2,7 @@ ...@@ -2,6 +2,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
module Gargantext.API.Auth.PolicyCheck ( module Gargantext.API.Auth.PolicyCheck (
AccessCheck(..) AccessCheck(..)
...@@ -34,12 +35,13 @@ import Gargantext.Database.Query.Tree.Root ...@@ -34,12 +35,13 @@ import Gargantext.Database.Query.Tree.Root
import Gargantext.Core.Config (GargConfig(..)) import Gargantext.Core.Config (GargConfig(..))
import Prelude import Prelude
import Servant import Servant
import Servant.API.Routes
import Servant.Auth.Server.Internal.AddSetCookie import Servant.Auth.Server.Internal.AddSetCookie
import Servant.Client.Core
import Servant.Ekg import Servant.Ekg
import Servant.Server.Internal.Delayed import Servant.Server.Internal.Delayed
import Servant.Server.Internal.DelayedIO import Servant.Server.Internal.DelayedIO
import qualified Servant.Swagger as Swagger import Servant.Swagger qualified as Swagger
import Servant.Client.Core
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Types -- Types
...@@ -203,6 +205,11 @@ instance HasClient m sub => HasClient m (PolicyChecked sub) where ...@@ -203,6 +205,11 @@ instance HasClient m sub => HasClient m (PolicyChecked sub) where
hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt . cl hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt . cl
instance (HasRoutes subApi) => HasRoutes (PolicyChecked subApi) where
getRoutes =
let apiRoutes = getRoutes @subApi
in apiRoutes
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Utility functions -- Utility functions
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
......
...@@ -17,7 +17,7 @@ import Control.Monad (fail) ...@@ -17,7 +17,7 @@ import Control.Monad (fail)
import Data.Pool (withResource) import Data.Pool (withResource)
import Database.PostgreSQL.Simple qualified as PGS import Database.PostgreSQL.Simple qualified as PGS
import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) ) import Gargantext.API.Admin.EnvTypes ( DevEnv(..), Mode(Dev) )
import Gargantext.API.Admin.Settings ( devJwkFile, devSettings, newPool ) import Gargantext.API.Admin.Settings ( devJwkFile, devSettings, newPool, SettingsFile (..), IniFile (..) )
import Gargantext.API.Errors.Types ( BackendInternalError ) import Gargantext.API.Errors.Types ( BackendInternalError )
import Gargantext.API.Prelude ( GargM ) import Gargantext.API.Prelude ( GargM )
import Gargantext.Core.NLP (nlpServerMap) import Gargantext.Core.NLP (nlpServerMap)
...@@ -30,10 +30,9 @@ import Gargantext.Core.Config.NLP qualified as NLP ...@@ -30,10 +30,9 @@ import Gargantext.Core.Config.NLP qualified as NLP
import Gargantext.System.Logging ( withLoggerHoisted ) import Gargantext.System.Logging ( withLoggerHoisted )
import Servant ( ServerError ) import Servant ( ServerError )
type IniPath = FilePath
------------------------------------------------------------------- -------------------------------------------------------------------
withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a withDevEnv :: IniFile -> SettingsFile -> (DevEnv -> IO a) -> IO a
withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do withDevEnv (IniFile iniPath) settingsFile k = withLoggerHoisted Dev $ \logger -> do
env <- newDevEnv logger env <- newDevEnv logger
k env -- `finally` cleanEnv env k env -- `finally` cleanEnv env
...@@ -44,7 +43,7 @@ withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do ...@@ -44,7 +43,7 @@ withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg) --nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
pool <- newPool dbParam pool <- newPool dbParam
nodeStory_env <- fromDBNodeStoryEnv pool nodeStory_env <- fromDBNodeStoryEnv pool
setts <- devSettings devJwkFile setts <- devSettings devJwkFile settingsFile
mail <- Mail.readConfig iniPath mail <- Mail.readConfig iniPath
nlp_config <- NLP.readConfig iniPath nlp_config <- NLP.readConfig iniPath
pure $ DevEnv pure $ DevEnv
...@@ -57,9 +56,15 @@ withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do ...@@ -57,9 +56,15 @@ withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do
, _dev_env_nlp = nlpServerMap nlp_config , _dev_env_nlp = nlpServerMap nlp_config
} }
defaultIniFile :: IniFile
defaultIniFile = IniFile "gargantext.ini"
defaultSettingsFile :: SettingsFile
defaultSettingsFile = SettingsFile "gargantext-settings.toml"
-- | Run Cmd Sugar for the Repl (GHCI) -- | Run Cmd Sugar for the Repl (GHCI)
runCmdRepl :: Show err => Cmd'' DevEnv err a -> IO a runCmdRepl :: Show err => Cmd'' DevEnv err a -> IO a
runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f runCmdRepl f = withDevEnv defaultIniFile defaultSettingsFile $ \env -> runCmdDev env f
runCmdReplServantErr :: Cmd'' DevEnv ServerError a -> IO a runCmdReplServantErr :: Cmd'' DevEnv ServerError a -> IO a
runCmdReplServantErr = runCmdRepl runCmdReplServantErr = runCmdRepl
...@@ -83,7 +88,7 @@ runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a ...@@ -83,7 +88,7 @@ runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
runCmdDevServantErr = runCmdDev runCmdDevServantErr = runCmdDev
runCmdReplEasy :: Cmd'' DevEnv BackendInternalError a -> IO a runCmdReplEasy :: Cmd'' DevEnv BackendInternalError a -> IO a
runCmdReplEasy f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f runCmdReplEasy f = withDevEnv defaultIniFile defaultSettingsFile $ \env -> runCmdDev env f
-- | Execute a function that takes PSQL.Connection from the DB pool as -- | Execute a function that takes PSQL.Connection from the DB pool as
-- first parameter. -- first parameter.
......
...@@ -13,13 +13,11 @@ module Gargantext.API.Routes.Named.Private ( ...@@ -13,13 +13,11 @@ module Gargantext.API.Routes.Named.Private (
, NodeAPIEndpoint(..) , NodeAPIEndpoint(..)
, MembersAPI(..) , MembersAPI(..)
, IsGenericNodeRoute(..) , IsGenericNodeRoute(..)
, NotesProxy(..)
) where ) where
import Data.Kind import Data.Kind
import Data.Text (Text) import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics import GHC.Generics
import GHC.TypeLits import GHC.TypeLits
import Gargantext.API.Admin.Auth.Types import Gargantext.API.Admin.Auth.Types
...@@ -98,12 +96,6 @@ data GargPrivateAPI' mode = GargPrivateAPI' ...@@ -98,12 +96,6 @@ data GargPrivateAPI' mode = GargPrivateAPI'
} deriving Generic } deriving Generic
data NotesProxy mode = NotesProxy
{ noteProxyEp :: mode :- Capture "frameId" T.Text
:> Raw
} deriving Generic
data GargAdminAPI mode = GargAdminAPI data GargAdminAPI mode = GargAdminAPI
{ rootsEp :: mode :- "user" :> Summary "First user endpoint" :> NamedRoutes Roots { rootsEp :: mode :- "user" :> Summary "First user endpoint" :> NamedRoutes Roots
, adminNodesAPI :: mode :- "nodes" :> Summary "Nodes endpoint" , adminNodesAPI :: mode :- "nodes" :> Summary "Nodes endpoint"
......
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Gargantext.API.Routes.Types where module Gargantext.API.Routes.Types where
import Control.Lens
import Data.ByteString (ByteString)
import Data.List qualified as L import Data.List qualified as L
import Data.Proxy import Data.Proxy
import Data.Set qualified as Set
import Gargantext.API.Errors import Gargantext.API.Errors
import Network.Wai import Network.Wai hiding (responseHeaders)
import Prelude import Prelude
import Servant.Client import Servant.API.Routes
import Servant.Client hiding (responseHeaders)
import Servant.Ekg import Servant.Ekg
import Servant.Server import Servant.Server
import Servant.Server.Internal.Delayed import Servant.Server.Internal.Delayed
import Servant.Server.Internal.DelayedIO import Servant.Server.Internal.DelayedIO
import Servant.API.Routes.Route
import Servant.API.Routes.Internal.Response (unResponses)
data WithCustomErrorScheme a data WithCustomErrorScheme a
...@@ -37,3 +44,10 @@ instance HasClient m sub => HasClient m (WithCustomErrorScheme sub) where ...@@ -37,3 +44,10 @@ instance HasClient m sub => HasClient m (WithCustomErrorScheme sub) where
clientWithRoute m _ req _mgr = clientWithRoute m (Proxy :: Proxy sub) req clientWithRoute m _ req _mgr = clientWithRoute m (Proxy :: Proxy sub) req
hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt . cl hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt . cl
instance (HasRoutes subApi) => HasRoutes (WithCustomErrorScheme subApi) where
getRoutes =
let apiRoutes = getRoutes @subApi
errHeader = mkHeaderRep @"X-Garg-Error-Scheme" @ByteString
addHeader rt = rt & routeResponse . unResponses . traversed . responseHeaders %~ Set.insert errHeader
in addHeader <$> apiRoutes
...@@ -9,15 +9,15 @@ import Data.HashMap.Strict as HM ...@@ -9,15 +9,15 @@ import Data.HashMap.Strict as HM
import Data.Text as T import Data.Text as T
import Data.Text.IO as T import Data.Text.IO as T
import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Time.Clock.POSIX (getPOSIXTime)
import Gargantext.API.Routes.Named.EKG
import Network.Wai import Network.Wai
import Protolude import Protolude
import Servant import Servant
import Servant.Auth import Servant.Auth
import Servant.Ekg import Servant.Ekg
import System.Metrics
import qualified System.Metrics.Json as J
import Gargantext.API.Routes.Named.EKG
import Servant.Server.Generic import Servant.Server.Generic
import System.Metrics
import System.Metrics.Json qualified as J
ekgServer :: FilePath -> Store -> EkgAPI AsServer ekgServer :: FilePath -> Store -> EkgAPI AsServer
......
...@@ -9,19 +9,22 @@ Portability : POSIX ...@@ -9,19 +9,22 @@ Portability : POSIX
-} -}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
module Gargantext.API.ThrowAll where module Gargantext.API.ThrowAll (
throwAllRoutes
, serverPrivateGargAPI
) where
import Control.Lens ((#)) import Control.Lens ((#))
import Data.ByteString.Char8 qualified as C8
import Gargantext.API.Admin.Auth.Types import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Admin.EnvTypes (Env) import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Errors.Types import Gargantext.API.Errors.Types
...@@ -29,31 +32,60 @@ import Gargantext.API.Prelude ...@@ -29,31 +32,60 @@ import Gargantext.API.Prelude
import Gargantext.API.Routes.Named.Private qualified as Named import Gargantext.API.Routes.Named.Private qualified as Named
import Gargantext.API.Server.Named.Private qualified as Named import Gargantext.API.Server.Named.Private qualified as Named
import Gargantext.Database.Admin.Types.Node (UserId (..)) import Gargantext.Database.Admin.Types.Node (UserId (..))
import Gargantext.Prelude import Gargantext.Prelude hiding (Handler)
import Network.HTTP.Types.Status (Status(..))
import Network.Wai (responseLBS)
import Servant import Servant
import Servant.API.Generic ()
import Servant.Auth.Server (AuthResult(..)) import Servant.Auth.Server (AuthResult(..))
import Servant.Server.Generic (AsServerT) import Servant.Server.Generic (AsServerT)
import Servant.API.Generic ()
-- | Slightly more general version of the 'ThrowAll' typeclass from Servant,
-- that works on a generic error.
class ThrowAll' e a where
throwAll' :: e -> a -> a
instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
throwAll' e (s1 :<|> s2) = throwAll' e s1 :<|> throwAll' e s2
instance ThrowAll' e b => ThrowAll' e (a -> b) where
throwAll' e f = \x -> throwAll' e (f x)
throwAll' :: forall err m routes. ( MonadError err m instance ( MonadError e m
, HasServerError err , GenericServant routes (AsServerT m)
, HasServer (NamedRoutes routes) '[] , HasServer (NamedRoutes routes) '[]
, Generic (routes (AsServerT m)) , Generic (routes (AsServerT m))
) => err ) => ThrowAll' e (routes (AsServerT m)) where
-> routes (AsServerT m) throwAll' errCode server = hoistServer (Proxy @(NamedRoutes routes)) f server
-> routes (AsServerT m) where
throwAll' errCode server = f :: forall a. m a -> m a
hoistServer (Proxy @(NamedRoutes routes)) f server f = const (throwError errCode)
where
f :: forall a. m a -> m a -- Common instances
f = const (throwError errCode)
instance (ThrowAll' ServerError (Handler a)) where
throwAll' e _ = throwError e
instance (ThrowAll' ServerError (Tagged Handler Application)) where
throwAll' ServerError{..} (Tagged _) =
Tagged $ \_ mkResponse -> mkResponse (responseLBS (Status errHTTPCode (C8.pack errReasonPhrase)) errHeaders errBody)
throwAllRoutes :: ( MonadError e m
, Generic (routes (AsServerT m))
, GenericServant routes (AsServerT m)
, ThrowAll' e (routes (AsServerT m))
, ThrowAll' e (ToServant routes (AsServerT m))
)
=> e
-> routes (AsServerT m)
-> routes (AsServerT m)
throwAllRoutes err = fromServant . throwAll' err . toServant
serverPrivateGargAPI :: Named.GargPrivateAPI (AsServerT (GargM Env BackendInternalError)) serverPrivateGargAPI :: Named.GargPrivateAPI (AsServerT (GargM Env BackendInternalError))
serverPrivateGargAPI = Named.GargPrivateAPI $ \case serverPrivateGargAPI = Named.GargPrivateAPI $ \case
(Authenticated auser) -> Named.serverPrivateGargAPI' auser (Authenticated auser) -> Named.serverPrivateGargAPI' auser
-- In the code below we just needed a mock 'AuthenticatedUser' to make the type check, but -- In the code below we just needed a mock 'AuthenticatedUser' to make the type check, but
-- they will never be evaluated. -- they will never be evaluated.
_ -> throwAll' (_ServerError # err401) _ -> throwAllRoutes (_ServerError # err401)
$ Named.serverPrivateGargAPI' (AuthenticatedUser 0 (UnsafeMkUserId 0)) $ Named.serverPrivateGargAPI' (AuthenticatedUser 0 (UnsafeMkUserId 0))
-- Here throwAll' requires a concrete type for the monad. -- Here throwAll' requires a concrete type for the monad.
...@@ -3,12 +3,19 @@ ...@@ -3,12 +3,19 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Gargantext.MicroServices.ReverseProxy ( module Gargantext.MicroServices.ReverseProxy (
microServicesProxyApp microServicesProxyApp
-- * Internals -- * Internals
, removeFromReferer , removeFromReferer
, ReverseProxyAPI(..)
, NotesProxy(..)
, FrameId(..)
) where ) where
import Prelude import Prelude
...@@ -25,21 +32,34 @@ import GHC.Generics ...@@ -25,21 +32,34 @@ import GHC.Generics
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.Routes.Named.Private
import Gargantext.API.ThrowAll (throwAllRoutes)
import Gargantext.API.Types (HTML) import Gargantext.API.Types (HTML)
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Prelude
import Gargantext.Core.Config (gc_frame_write_url) import Gargantext.Core.Config (gc_frame_write_url)
import Gargantext.Database.Prelude (hasConfig)
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)
import Network.Wai (Request, rawPathInfo, requestHeaders)
import Servant hiding (Header) import Servant hiding (Header)
import Servant.Auth.Server
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 Text.RawString.QQ (r)
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Servant.Auth.Server.Internal.AddSetCookie
import Network.Wai
-- See https://github.com/haskell-servant/servant/issues/1601#issue-1338013029
instance {-# OVERLAPPING #-}
( AddSetCookies ('S n) a a
, AddSetCookies ('S n) b b'
)
=> AddSetCookies ('S n) (a :<|> b) (a :<|> b') where
addSetCookies cookies ( a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b
-- --
-- Types -- Types
...@@ -48,6 +68,9 @@ import Text.RawString.QQ (r) ...@@ -48,6 +68,9 @@ import Text.RawString.QQ (r)
newtype FrameId = FrameId { _FrameId :: T.Text } newtype FrameId = FrameId { _FrameId :: T.Text }
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
instance ToHttpApiData FrameId where
toUrlPiece = toUrlPiece . _FrameId
-- | The service type that our microservices proxy will handle. At the moment -- | The service type that our microservices proxy will handle. At the moment
-- we support only the \"notes\" one. -- we support only the \"notes\" one.
data ServiceType data ServiceType
...@@ -85,7 +108,7 @@ fwdPort = baseUrlPort . _ProxyDestination ...@@ -85,7 +108,7 @@ fwdPort = baseUrlPort . _ProxyDestination
data ReverseProxyAPI mode = ReverseProxyAPI data ReverseProxyAPI mode = ReverseProxyAPI
{ -- | The proxy routes for the \"notes\" microservice (e.g. \"write.frame.gargantext.org\"). { -- | The proxy routes for the \"notes\" microservice (e.g. \"write.frame.gargantext.org\").
notesServiceProxy :: mode :- "notes" :> NamedRoutes NotesProxy notesServiceProxy :: mode :- "notes" :> MkProtectedAPI (NamedRoutes NotesProxy)
-- | proxy everything else. CAREFUL! This has to be the last route, as it will always match. -- | proxy everything else. CAREFUL! This has to be the last route, as it will always match.
, proxyPassAll :: mode :- Raw , proxyPassAll :: mode :- Raw
...@@ -124,13 +147,20 @@ data SocketIOProxy mode = SocketIOProxy ...@@ -124,13 +147,20 @@ data SocketIOProxy mode = SocketIOProxy
-- --
microServicesProxyApp :: Env -> Application microServicesProxyApp :: Env -> Application
microServicesProxyApp env = genericServe (server env) microServicesProxyApp env = genericServeTWithContext id (server env) cfg
where
cfg :: Context AuthContext
cfg = env ^. settings . jwtSettings
:. env ^. settings . cookieSettings
:. EmptyContext
server :: Env -> ReverseProxyAPI AsServer server :: Env -> ReverseProxyAPI (AsServerT Handler)
server env = ReverseProxyAPI { server env = ReverseProxyAPI {
notesServiceProxy = notesProxyImplementation env notesServiceProxy = \case
, proxyPassAll = proxyPassServer ST_notes env (Authenticated _autUser) -> notesProxyImplementation env
} _ -> throwAllRoutes err401 $ notesProxyImplementation env
, proxyPassAll = proxyPassServer ST_notes env
}
-- | A customised configuration file that the \"notes\" service would otherwise send us, that -- | A customised 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
......
...@@ -108,6 +108,10 @@ ...@@ -108,6 +108,10 @@
git: "https://github.com/delanoe/patches-map" git: "https://github.com/delanoe/patches-map"
subdirs: subdirs:
- . - .
- commit: 7694f62af6bc1596d754b42af16da131ac403b3a
git: "https://github.com/fpringle/servant-routes.git"
subdirs:
- .
- commit: 23be4130804d86979eaee5caffe323a1c7f2b0d6 - commit: 23be4130804d86979eaee5caffe323a1c7f2b0d6
git: "https://github.com/garganscript/nanomsg-haskell" git: "https://github.com/garganscript/nanomsg-haskell"
subdirs: subdirs:
......
[cors]
allowed-origins = [
"https://demo.gargantext.org"
, "https://formation.gargantext.org"
, "https://academia.sub.gargantext.org"
, "https://cnrs.gargantext.org"
, "https://imt.sub.gargantext.org"
, "https://helloword.gargantext.org"
, "https://complexsystems.gargantext.org"
, "https://europa.gargantext.org"
, "https://earth.sub.gargantext.org"
, "https://health.sub.gargantext.org"
, "https://msh.sub.gargantext.org"
, "https://dev.sub.gargantext.org"
, "http://localhost:8008"
]
use-origins-for-hosts = true
[microservices]
proxy-port = 8009
...@@ -53,7 +53,6 @@ mkUrl _port urlPiece = ...@@ -53,7 +53,6 @@ mkUrl _port urlPiece =
clientRoutes :: API (AsClientT ClientM) clientRoutes :: API (AsClientT ClientM)
clientRoutes = genericClient clientRoutes = genericClient
-- This is for Servant.Client requests -- This is for Servant.Client requests
auth_api :: AuthRequest -> ClientM AuthResponse auth_api :: AuthRequest -> ClientM AuthResponse
auth_api = clientRoutes & apiWithCustomErrorScheme auth_api = clientRoutes & apiWithCustomErrorScheme
......
...@@ -3,9 +3,8 @@ ...@@ -3,9 +3,8 @@
module Test.API.Setup where module Test.API.Setup where
-- import Gargantext.Prelude (printDebug) import Control.Concurrent.Async qualified as Async
import Control.Concurrent (forkIO, killThread) import Control.Concurrent.MVar
import Control.Exception (bracket)
import Control.Lens import Control.Lens
import Control.Monad.Reader import Control.Monad.Reader
import Gargantext.API (makeApp) import Gargantext.API (makeApp)
...@@ -17,6 +16,9 @@ import Gargantext.API.Prelude ...@@ -17,6 +16,9 @@ import Gargantext.API.Prelude
import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE import Gargantext.Core.AsyncUpdates.CentralExchange qualified as CE
import Gargantext.Core.AsyncUpdates.Dispatcher qualified as D import Gargantext.Core.AsyncUpdates.Dispatcher qualified as D
import Gargantext.Core.AsyncUpdates.Dispatcher.Types qualified as DT import Gargantext.Core.AsyncUpdates.Dispatcher.Types qualified as DT
import Gargantext.Core.Config
import Gargantext.Core.Config.Mail qualified as Mail
import Gargantext.Core.Config.NLP qualified as NLP
import Gargantext.Core.NLP import Gargantext.Core.NLP
import Gargantext.Core.NodeStory import Gargantext.Core.NodeStory
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
...@@ -28,9 +30,7 @@ import Gargantext.Database.Admin.Types.Hyperdata ...@@ -28,9 +30,7 @@ import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Prelude import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (getOrMkList) import Gargantext.Database.Query.Table.Node (getOrMkList)
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..)) import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..))
import Gargantext.Core.Config import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
import Gargantext.Core.Config.Mail qualified as Mail
import Gargantext.Core.Config.NLP qualified as NLP
import Gargantext.System.Logging import Gargantext.System.Logging
import Gargantext.Utils.Jobs qualified as Jobs import Gargantext.Utils.Jobs qualified as Jobs
import Gargantext.Utils.Jobs.Monad qualified as Jobs import Gargantext.Utils.Jobs.Monad qualified as Jobs
...@@ -38,20 +38,25 @@ import Gargantext.Utils.Jobs.Queue qualified as Jobs ...@@ -38,20 +38,25 @@ import Gargantext.Utils.Jobs.Queue qualified as Jobs
import Gargantext.Utils.Jobs.Settings qualified as Jobs import Gargantext.Utils.Jobs.Settings qualified as Jobs
import Network.HTTP.Client.TLS (newTlsManager) import Network.HTTP.Client.TLS (newTlsManager)
import Network.Wai (Application) import Network.Wai (Application)
import Network.Wai.Handler.Warp (runSettingsSocket)
import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Handler.Warp qualified as Warp
import Network.Wai.Handler.Warp.Internal
import Prelude import Prelude
import Servant.Auth.Client () import Servant.Auth.Client ()
import Servant.Client import Servant.Client
import Servant.Job.Async qualified as ServantAsync import Servant.Job.Async qualified as ServantAsync
import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo) import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo, fakeSettingsPath)
import Test.Database.Types import Test.Database.Types
import qualified UnliftIO
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
newTestEnv testEnv logger port = do newTestEnv testEnv logger port = do
file <- fakeIniPath file <- fakeIniPath
settingsP <- SettingsFile <$> fakeSettingsPath
!manager_env <- newTlsManager !manager_env <- newTlsManager
!settings' <- devSettings devJwkFile <&> appPort .~ port !settings' <- devSettings devJwkFile settingsP <&> appPort .~ port
!config_env <- readConfig file !config_env <- readConfig file
prios <- withLogger () $ \ioLogger -> Jobs.readPrios ioLogger (file <> ".jobs") prios <- withLogger () $ \ioLogger -> Jobs.readPrios ioLogger (file <> ".jobs")
...@@ -92,10 +97,8 @@ newTestEnv testEnv logger port = do ...@@ -92,10 +97,8 @@ newTestEnv testEnv logger port = do
-- , _env_dispatcher = dispatcher -- , _env_dispatcher = dispatcher
} }
withGargApp :: Application -> (Warp.Port -> IO ()) -> IO () -- | Run the gargantext server on a random port, picked by Warp, which allows
withGargApp app action = do -- for concurrent tests to be executed in parallel, if we need to.
Warp.testWithApplication (pure app) action
withTestDBAndPort :: (((TestEnv, Warp.Port), Application) -> IO ()) -> IO () withTestDBAndPort :: (((TestEnv, Warp.Port), Application) -> IO ()) -> IO ()
withTestDBAndPort action = withTestDBAndPort action =
withTestDB $ \testEnv -> do withTestDB $ \testEnv -> do
...@@ -124,8 +127,25 @@ withTestDBAndPort action = ...@@ -124,8 +127,25 @@ withTestDBAndPort action =
app <- withLoggerHoisted Mock $ \ioLogger -> do app <- withLoggerHoisted Mock $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080 env <- newTestEnv testEnv ioLogger 8080
makeApp env makeApp env
withGargApp app $ \port -> Warp.testWithApplication (pure app) $ \port -> action ((testEnv, port), app)
action ((testEnv, port), app)
-- | Starts the backend server /and/ the microservices proxy, the former at
-- a random port, the latter at a predictable port.
withBackendServerAndProxy :: (((TestEnv, Warp.Port, Warp.Port)) -> IO ()) -> IO ()
withBackendServerAndProxy action =
withTestDB $ \testEnv -> do
gargApp <- withLoggerHoisted Mock $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080
makeApp env
proxyApp <- withLoggerHoisted Mock $ \ioLogger -> do
env <- newTestEnv testEnv ioLogger 8080
pure $ microServicesProxyApp env
Warp.testWithApplication (pure gargApp) $ \serverPort ->
testWithApplicationOnPort (pure proxyApp) proxyPort $
action (testEnv, serverPort, proxyPort)
where
proxyPort = 8090
setupEnvironment :: TestEnv -> IO () setupEnvironment :: TestEnv -> IO ()
setupEnvironment env = flip runReaderT env $ runTestMonad $ do setupEnvironment env = flip runReaderT env $ runTestMonad $ do
...@@ -147,3 +167,40 @@ createAliceAndBob testEnv = do ...@@ -147,3 +167,40 @@ createAliceAndBob testEnv = do
void $ new_user nur1 void $ new_user nur1
void $ new_user nur2 void $ new_user nur2
-- | A version of 'withApplication' that allows supplying a user-specified port
-- so that we are sure that our garg apps will run on the same port as specified
-- in the 'Env' settings.
testWithApplicationOnPort :: IO Application -> Warp.Port -> IO a -> IO a
testWithApplicationOnPort mkApp userPort action = do
app <- mkApp
started <- mkWaiter
let appSettings =
Warp.defaultSettings
{ settingsBeforeMainLoop =
notify started () >> settingsBeforeMainLoop Warp.defaultSettings
, settingsPort = userPort
}
sock <- bindPortTCP userPort "127.0.0.1"
result <-
Async.race
(runSettingsSocket appSettings sock app)
(waitFor started >> action)
case result of
Left () -> UnliftIO.throwString "Unexpected: runSettingsSocket exited"
Right x -> return x
data Waiter a = Waiter
{ notify :: a -> IO ()
, waitFor :: IO a
}
mkWaiter :: IO (Waiter a)
mkWaiter = do
mvar <- newEmptyMVar
return
Waiter
{ notify = putMVar mvar
, waitFor = readMVar mvar
}
...@@ -2,6 +2,7 @@ ...@@ -2,6 +2,7 @@
module Test.Database.Setup ( module Test.Database.Setup (
withTestDB withTestDB
, fakeIniPath , fakeIniPath
, fakeSettingsPath
, testEnvToPgConnectionInfo , testEnvToPgConnectionInfo
) where ) where
...@@ -35,6 +36,9 @@ dbName = "gargandb_test" ...@@ -35,6 +36,9 @@ dbName = "gargandb_test"
fakeIniPath :: IO FilePath fakeIniPath :: IO FilePath
fakeIniPath = getDataFileName "test-data/test_config.ini" fakeIniPath = getDataFileName "test-data/test_config.ini"
fakeSettingsPath :: IO FilePath
fakeSettingsPath = getDataFileName "test-data/gargantext-settings.toml"
gargDBSchema :: IO FilePath gargDBSchema :: IO FilePath
gargDBSchema = getDataFileName "devops/postgres/schema.sql" gargDBSchema = getDataFileName "devops/postgres/schema.sql"
...@@ -74,7 +78,7 @@ setup = do ...@@ -74,7 +78,7 @@ setup = do
bootstrapDB db pool gargConfig bootstrapDB db pool gargConfig
ugen <- emptyCounter ugen <- emptyCounter
test_nodeStory <- fromDBNodeStoryEnv pool test_nodeStory <- fromDBNodeStoryEnv pool
stgs <- devSettings devJwkFile stgs <- devSettings devJwkFile =<< (SettingsFile <$> fakeSettingsPath)
withLoggerHoisted Mock $ \logger -> do withLoggerHoisted Mock $ \logger -> do
pure $ TestEnv { test_db = DBHandle pool db pure $ TestEnv { test_db = DBHandle pool db
, test_config = gargConfig , test_config = gargConfig
......
module Test.Server.ReverseProxy where
import Data.Function ((&))
import Gargantext.MicroServices.ReverseProxy
import Network.HTTP.Client
import Network.HTTP.Types.Status
import Prelude
import Servant.Auth.Client (Token(..))
import Servant.Client
import Servant.Client.Generic (genericClient)
import Test.API.Setup (setupEnvironment, withBackendServerAndProxy, createAliceAndBob)
import Test.Hspec
import Gargantext.Core.Types.Individu (GargPassword(..))
import Gargantext.API.Admin.Auth.Types
import Test.API.Authentication (auth_api)
import Control.Lens ((^.))
import Test.API.Routes (toServantToken)
reverseProxyClient :: ReverseProxyAPI (AsClientT ClientM)
reverseProxyClient = genericClient
tests :: Spec
tests = describe "Microservices proxy" $ do
writeFrameTests
writeFrameTests :: Spec
writeFrameTests = sequential $ aroundAll withBackendServerAndProxy $ do
describe "Prelude" $ do
it "setup DB triggers" $ \(testEnv, _, _) -> setupEnvironment testEnv
describe "Write Frame Reverse Proxy" $ do
it "should disallow unauthenticated requests" $ \(_testEnv, _serverPort, proxyPort) -> do
baseUrl <- parseBaseUrl "http://localhost"
manager <- newManager defaultManagerSettings
let clientEnv prt = mkClientEnv manager (baseUrl { baseUrlPort = prt })
result <- runClientM (reverseProxyClient & notesServiceProxy
& ($ (Token "bogus"))
& notesEp
& ($ (FrameId "abcdef"))
& ($ "GET")
) (clientEnv proxyPort)
case result of
Right response
-> responseStatusCode response `shouldBe` status401
Left (FailureResponse _ response)
-> responseStatusCode response `shouldBe` status401
Left err
-> fail (show err)
it "should allow authenticated requests" $ \(testEnv, serverPort, proxyPort) -> do
-- Let's create the Alice user.
createAliceAndBob testEnv
baseUrl <- parseBaseUrl "http://localhost"
manager <- newManager defaultManagerSettings
let clientEnv prt = mkClientEnv manager (baseUrl { baseUrlPort = prt })
let authPayload = AuthRequest "alice@gargan.text" (GargPassword "alice")
result0 <- runClientM (auth_api authPayload) (clientEnv serverPort)
case result0 of
Left err -> fail (show err)
Right autRes -> do
result <- runClientM (reverseProxyClient & notesServiceProxy
& ($ (toServantToken $ autRes ^. authRes_token))
& notesEp
& ($ (FrameId "abcdef"))
& ($ "GET")
) (clientEnv proxyPort)
-- The actual request to the reverse proxy might fail (because our
-- environment is not setup correctly, for example) but crucially here
-- we want to test that with a valid authentication we don't hit the
-- 401 error.
case result of
Right response
-> responseStatusCode response `shouldNotBe` status401
Left (FailureResponse _ response)
-> responseStatusCode response `shouldNotBe` status401
Left err
-> fail (show err)
...@@ -16,6 +16,7 @@ import System.Process ...@@ -16,6 +16,7 @@ import System.Process
import Test.Hspec import Test.Hspec
import qualified Data.Text as T import qualified Data.Text as T
import qualified Test.API as API import qualified Test.API as API
import qualified Test.Server.ReverseProxy as ReverseProxy
import qualified Test.Database.Operations as DB import qualified Test.Database.Operations as DB
...@@ -72,5 +73,6 @@ main = do ...@@ -72,5 +73,6 @@ main = do
bracket startNotifications stopNotifications $ \_ -> do bracket startNotifications stopNotifications $ \_ -> do
bracket startCoreNLPServer stopCoreNLPServer $ \_ -> hspec $ do bracket startCoreNLPServer stopCoreNLPServer $ \_ -> hspec $ do
API.tests API.tests
ReverseProxy.tests
DB.tests DB.tests
DB.nodeStoryTests DB.nodeStoryTests
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