Skip to content

haskell-gargantext
haskell-gargantext
Commit fff00f20 authored by Karen Konou's avatar Karen Konou
1 Browse files
Options

Merge branch 'dev' into 689-dev-graph-legend-show-all-clusters

parents 3da7a409 2df4c3bd
Pipeline #6897 passed with stages
          in 50 minutes and 16 seconds
          Hide whitespace changes
          Inline Side-by-side
          Showing with 376005 additions and 484 deletions
          CHANGELOG.md
          View file @ fff00f20
          ## Version 0.0.7.3.5
          * [FRONT][FIX][[Topbar] Update the navigation bar links in the "Info" dropdown (#710)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/710)
          ## Version 0.0.7.3.4
          * [FRONT][FIX][Sigma settings don't apply sometimes (#708)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/708)
          ## Version 0.0.7.3.3
          * [FRONT][FIX][Display graph parameters in legend (#706)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/706)
          * [BACK][FIX][Document Search (#415)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/415)
          * [BACK][DOC+Scripts][Improving onboarding
          experience](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/360)
          ## Version 0.0.7.3.2
          * [FRONT][FIX][[Node Graph] Legend tab improvements (#689)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/689)
          ......
          README.md
          View file @ fff00f20
          ......@@ -7,10 +7,9 @@
          #### Table of Contents
          1. [About the project](#about)
          2. [Installation and development](#install)
          3. [Uses cases](#use-cases)
          4. [GraphQL](#graphql)
          5. [PostgreSQL](#postgresql)
          2. [Installation](#install)
          3. [Use cases](#use-cases)
          4. [Notes for developers](#develop)
          ## About the project <a name="about"></a>
          ......@@ -21,107 +20,136 @@ 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).
          ## Installation and development <a name="install"></a>
          ## Installation <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.
          ### Prerequisites
          You must have the following installed:
          You need to have the following installed:
          * [GHCup](https://www.haskell.org/ghcup/)
          * [Git](https://git-scm.com/book/en/v2/Getting-Started-Installing-Git)
          * [Nix](https://nixos.org/download/)
          * [Docker Compose](https://docs.docker.com/compose/install/).
          - [Git](https://git-scm.com/book/en/v2/Getting-Started-Installing-Git)
          - [Curl](https://everything.curl.dev/index.html)
          - [Nix](https://nixos.org/download/)
          - [Docker Compose](https://docs.docker.com/compose/install/)
          ### Building
          You will need to add yourself as a member of the `docker` group for Docker
          Compose to work (replace `myusername` with your username in the following
          command):
          ```bash
          sudo usermod -a -G docker myusername
          ```
          #### Clone the projects
          ### Getting the source code
          Clone both the backend (`haskell-gargantext`), and the frontend (`purescript-gargantext`) at the root of the backend.
          ```shell
          $ git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
          $ cd haskell-gargantext
          $ git clone https://gitlab.iscpif.fr/gargantext/purescript-gargantext.git
          $ cd ..
          ```bash
          git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
          cd haskell-gargantext
          git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
          cd ..
          ```
          #### The Nix shell
          ### Building Gargantext
          In what follows, many commands need to be executed from within the Nix shell. To make that clear, those will be prefixed with `n$`, *but you must not actually type `n$` before the commands*.
          To enter a Nix shell, run the following (this will take a moment the first time you run it, be patient):
          ```shell
          $ nix-shell
          #### Building the Backend
          Run the install script from inside the `haskell-gargantext/` directory:
          ```bash
          ./bin/install
          ```
          Once you are in a Nix shell, you can run commands like you would in any other shell.
          This will build Gargantext, run the tests, and build the documentation.
          At any point, you can exit a Nix shell and go back to your regular shell by running `exit`.
          #### Building the Frontend
          If for some reason you do not want to enter a Nix shell, you can still run a command from outside: running the following in a non-Nix shell
          ```shell
          $ nix-shell --run "my command"
          Move into the `purescript-gargantext/` directory, then run the install script:
          ```bash
          cd purescript-gargantext
          ./bin/install
          cd ..
          ```
          is equivalent to running `my command` from within a Nix shell.
          #### (Optional) Disable optimization flags
          ### Initialization
          If you are developing Gargantext, you might be interested in disabling compiler optimizations.
          This speeds up compilation, but the compiled program itself will be less efficient.
          Rename the `gargantext-settings.toml_toModify` into `gargantext-settings.toml`,
          and fill in the missing fields.
          To disable compiler optimizations, copy the file `cabal.project.local_toCopy` (which contains the flags that disable optimizations) into `cabal.project.local` (which will be read by Cabal):
          > `.gitignore` excludes this file, so you don't need to worry about committing
          > it by mistake, and you can change the passwords in `gargantext-settings.toml`
          > safely.
          **NOTE** If you had the `gargantext.ini` file before, you can automatically
          convert it into a file `gargantext-settings.toml` by running the following
          from a Nix shell:
          ```shell
          $ cp cabal.project.local_toCopy cabal.project.local
          n$ ./bin/cli ini
          ```
          #### Build the frontend
          ### Launching and Initializing the Database
          ```shell
          $ cd purescript-gargantext/
          $ ./bin/install
          $ cd ..
          Launch the docker image from inside the dedicated directory:
          ```bash
          cd devops/docker/
          docker compose up
          ```
          #### Build the backend
          Then initialize the database using the dedicated command: from inside the
          `haskell-gargantext/` directory, run
          ```bash
          ./bin/cli init
          ```
          *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.*
          And provide a name and a password for the master user as requested.
          *This documentation shows how to build with cabal. For information related to stack, see [the note about Stack](https://write.frame.gargantext.org/s/2b50f559075be33faad884e13899a66fc6865c41b97d87772f8bc447234995f7) in the developer documentation.*
          ### Running Gargantext
          Depending on your situation, there are several ways to build the project:
          From inside the `haskell-gargantext/` directory, run
          ```bash
          ./bin/run
          ```
          1. **Simple build**
          ## Use Cases <a name="use-cases"></a>
          *This will build the project and install the executables `gargantext-cli` and `gargantext-server` somewhere on your system.
          Depending on your Cabal configuration, this is probably `~/.local/bin/` or `~/.cabal/bin/`.*
          ### Multi-User with Graphical User Interface (Server Mode)
          From within the Nix shell, run:
          ```shell
          n$ cabal update
          n$ cabal install
          ``` shell
          $ ~/.local/bin/stack --docker exec gargantext-server -- --run Prod
          ```
          2. **Full build**
          Then you can log in with `user1` / `1resu`
          *Same as "simple build" above, but also runs tests and builds documentation.*
          ### Command Line Mode tools
          Just run the `install` script:
          #### Simple cooccurrences computation and indexation from a list of Ngrams
          ```shell
          $ ./bin/install
          ``` shell
          $ stack --docker exec gargantext-cli -- CorpusFromGarg.csv ListFromGarg.csv Ouput.json
          ```
          3. **Build and run**
          ### Analyzing the ngrams table repo
          *Builds and runs the Gargantext server. This has the advantage of letting you run Gargantext without having to know where on your machine the executable is.*
          We store the repository in directory `repos` in the [CBOR](https://cbor.io/) file format. To decode it to JSON and analyze, say, using [jq](https://shapeshed.com/jq-json/), use the following command:
          *Since you will be running Gargantext,* **you need to have gone through initialization first;** *see "Initializing and running" below.*
          ``` shell
          $ cat repos/repo.cbor.v5 | stack exec gargantext-cbor2json | jq .
          ```
          ### Documentation
          To build documentation, run:
          From inside a Nix shell:
          ```shell
          n$ cabal run gargantext-server -- --toml gargantext-settings.toml --run Prod
          $ stack build --haddock --no-haddock-deps --fast
          ```
          #### Upgrading haskell packages
          (in `.stack-work/dist/x86_64-linux-nix/Cabal-3.2.1.0/doc/html/gargantext`).
          ## Notes for developers <a name="develop"></a>
          ### Developer Documentation
          If you want to contribute to Gargantext, there is [some documentation geared to developers](https://write.frame.gargantext.org/s/805e1ee2bae24079554d24cdbc8ef5ba5c4ef7d83218c1e86c84af8ac269031d).
          ### Upgrading Haskell Packages
          We use `gargantext.cabal`, `cabal.project` and `cabal.project.freeze`
          as the source of truth. Ouf ot that, we generate the `stack.yaml` file
          ......@@ -173,54 +201,7 @@ with `cabal v2-build all`).
          Also, here is a relevant discussion:
          https://discourse.haskell.org/t/whats-your-workflow-to-update-cabal-dependencies/9475
          ### Initializing and running
          #### Start containers for database and NLP software bricks
          ```shell
          $ cd devops/docker
          $ docker compose up
          ```
          The initialization schema should be loaded automatically from `devops/postgres/schema.sql`.
          #### Create configuration file
          ```shell
          $ cp gargantext-settings.toml_toModify gargantext-settings.toml
          ```
          **NOTE** If you had the `gargantext.ini` file before, you can automatically
          convert it into a file `gargantext-settings.toml` by running the following
          from a Nix shell:
          ```shell
          n$ cabal v2-run gargantext-cli -- ini
          ```
          > `.gitignore` excludes this file, so you don't need to worry about
          > committing it by mistake, and you can change the passwords in
          > `gargantext-settings.toml` safely.
          #### Create master user
          From within the Nix shell:
          ```shell
          n$ gargantext-cli init
          ```
          The master user's name is automatically set to `gargantua`, but you will be prompted for their password and email address.
          #### Running
          Make sure you know where `gargantext-server` is (probably in `~/.local/bin/` or `.cabal/bin/`). If the location is in your `$PATH`, just run:
          ```shell
          $ gargantext-server --run Prod --toml gargantext-settings.toml
          ```
          (If the location is not in your `$PATH`, just prefix `gargantext-server` with the path to it.)
          You might want to use the `./start` script: it rebuilds the backend, starts the docker containers, and launches the Gargantext server at once.
          ### Running tests
          ### Running Tests
          From nix shell:
          ......@@ -265,7 +246,7 @@ export TMPDIR=$(pwd)/_build
          ### Working on libraries
          When a devlopment is needed on libraries (for instance, the HAL crawler in https://gitlab.iscpif.fr/gargantext/crawlers):
          When a development is needed on libraries (for instance, the HAL crawler in https://gitlab.iscpif.fr/gargantext/crawlers):
          1. Ongoing devlopment (on local repo):
          1. In `cabal.project`:
          ......@@ -280,56 +261,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.
          ### Tooling info
          Once you get Gargantext to compile and run on your machine, you will likely want
          the following:
          - Language support (intellisense) in your editor; see `docs/editor_setup.md`
          - Being able to send commands to the Gargantext server from GHCI; see `docs/running_commands.md`
          ## Use Cases <a name="use-cases"></a>
          ### Multi-User with Graphical User Interface (Server Mode)
          ``` shell
          $ ~/.local/bin/stack --docker exec gargantext-server -- --run Prod
          ```
          Then you can log in with `user1` / `1resu`
          ### Command Line Mode tools
          #### Simple cooccurrences computation and indexation from a list of Ngrams
          ``` shell
          $ stack --docker exec gargantext-cli -- CorpusFromGarg.csv ListFromGarg.csv Ouput.json
          ```
          ### Analyzing the ngrams table repo
          We store the repository in directory `repos` in the [CBOR](https://cbor.io/) file format. To decode it to JSON and analyze, say, using [jq](https://shapeshed.com/jq-json/), use the following command:
          ``` shell
          $ cat repos/repo.cbor.v5 | stack exec gargantext-cbor2json | jq .
          ```
          ### Documentation
          To build documentation, run:
          ```shell
          $ stack build --haddock --no-haddock-deps --fast
          ```
          (in `.stack-work/dist/x86_64-linux-nix/Cabal-3.2.1.0/doc/html/gargantext`).
          ## GraphQL <a name="graphql"></a>
          ### GraphQL
          Some introspection information.
          Playground is located at http://localhost:8008/gql
          ### List all GraphQL types in the Playground
          #### List all GraphQL types in the Playground
          ```
          {
          ......@@ -341,7 +279,7 @@ Playground is located at http://localhost:8008/gql
          }
          ```
          ### List details about a type in GraphQL
          #### List details about a type in GraphQL
          ```
          {
          ......@@ -356,9 +294,9 @@ Playground is located at http://localhost:8008/gql
          }
          }
          ```
          ## PostgreSQL <a name="pgsql"></a>
          ### PostgreSQL <a name="pgsql"></a>
          ### Upgrading using Docker
          #### Upgrading using Docker
          https://www.cloudytuts.com/tutorials/docker/how-to-upgrade-postgresql-in-docker-and-kubernetes/
          ......@@ -383,7 +321,7 @@ $ # now we can restore the dump
          $ docker exec -i <new-container-id> psql -U gargantua -d gargandbV5 < 11-db.dump
          ```
          ### Upgrading using
          #### Upgrading using
          There is a solution using pgupgrade_cluster but you need to manage the clusters version 14 and 13. Hence here is a simple solution to upgrade.
          ......@@ -408,9 +346,8 @@ Maybe you need to restore the gargantua password
          ```shell
          $ ALTER ROLE gargantua PASSWORD 'yourPasswordIn_gargantext-settings.toml'
          ```
          Maybe you need to change the port to 5433 for database connection in your gargantext.ini file.
          Maybe you need to change the port to 5433 for database connection in your gargantext.ini file.
          ## `haskell-language-server`
          ......@@ -420,3 +357,34 @@ with `ghcup`:
          ghcup compile hls --version 2.7.0.0 --ghc 9.4.7
          ```
          https://haskell-language-server.readthedocs.io/en/latest/installation.html
          ## Running the tests
          Running the tests can be done via the following command:
          ```hs
          cabal v2-test --test-show-details=streaming --flags 'test-crypto no-phylo-debug-logs'
          ```
          The flags have the following meaning:
          * `test-crypto`: Switch to use very fast (but not production-secure) cryptography, so that tests runs
          faster;
          * `no-phylo-debug-logs`: Suppresses the debugging logs which would normally be present in phylo pure (!) code.
          In order for some tests to run (like the phylo ones) is **required** to install the `gargantext-cli` via:
          ```hs
          cabal v2-install gargantext:exe:gargantext-cli
          ```
          ### Modifying a golden test to accept a new (expected) output
          Some tests, like the Phylo one, use golden testing to ensure that the JSON Phylo we generate is
          the same as an expected one. This allows us to catch regressions in the serialisation or in the algorithm.
          Sometimes, however, we genuinely want to modify the output so that it's the new reference (i.e. the new
          golden reference). To do so, it's enough to run the testsuite passing the `--accept` flag, for example:
          ```hs
          cabal v2-test garg-test-tasty --test-show-details=streaming --flags 'test-crypto no-phylo-debug-logs' --test-option=--pattern='/Phylo/' --test-option=--accept"
          ```
          bin/cli 0 → 100755
          View file @ fff00f20
          # The following line is more portable than just /bin/bash:
          #!/usr/bin/env bash
          # A couple hygienic options
          set -e -u
          # The following command will run `cabal run gargantext-cli --` followed by the
          # options provided by the user, from inside a Nix shell. For instance,
          # if the user types
          # $ ./bin/cli someCommand "some string argument"
          # the following will be run from inside a Nix shell:
          # $ cabal run gargantext-cli -- someCommand "some string argument"
          # It's a little convoluted because we want to keep spaces that were enclosed in
          # quotes or escaped by the user.
          nix-shell --run "$(printf "%q " cabal run gargantext-cli -- "$@")"
          bin/run 0 → 100755
          View file @ fff00f20
          # The following line is more portable than just /bin/bash:
          #!/usr/bin/env bash
          # A couple hygienic options
          set -e -u
          echo "Launching Gargantext..."
          nix-shell --run "cabal run gargantext-server -- --run Prod --toml gargantext-settings.toml"
          gargantext.cabal
          View file @ fff00f20
          ......@@ -5,7 +5,7 @@ cabal-version: 3.4
          -- see: https://github.com/sol/hpack
          name: gargantext
          version: 0.0.7.3.2
          version: 0.0.7.3.5
          synopsis: Search, map, share
          description: Please see README.md
          category: Data
          ......@@ -32,23 +32,24 @@ data-files:
          ekg-assets/bootstrap-1.4.0.min.css
          ekg-assets/chart_line_add.png
          ekg-assets/cross.png
          test-data/ngrams/GarganText_NgramsTerms-QuantumComputing.json
          test-data/ngrams/GarganText_DocsList-nodeId-177.json
          test-data/ngrams/GarganText_NgramsTerms-nodeId-177.json
          test-data/ngrams/GarganText_NgramsTerms-QuantumComputing.json
          test-data/ngrams/simple.json
          test-data/ngrams/simple.tsv
          test-data/phylo/187481.json
          test-data/phylo/bpa_phylo_test.json
          test-data/phylo/cleopatre.golden.json
          test-data/phylo/nadal.golden.json
          test-data/phylo/issue-290-small.golden.json
          test-data/phylo/nadal_docslist.golden.tsv
          test-data/phylo/nadal.golden.json
          test-data/phylo/nadal_ngramslist.golden.tsv
          test-data/phylo/issue-290-small.golden.json
          test-data/phylo/open_science.json
          test-data/phylo/small-phylo.golden.json
          test-data/phylo/phylo2dot2json.golden.json
          test-data/phylo/small_phylo_docslist.tsv
          test-data/phylo/small-phylo.golden.json
          test-data/phylo/small_phylo_ngramslist.tsv
          test-data/phylo/187481.json
          test-data/phylo/phylo2dot2json.golden.json
          test-data/search/GarganText_DocsList-soysauce.json
          test-data/stemming/lancaster.txt
          test-data/test_config.ini
          test-data/test_config.toml
          ......@@ -723,6 +724,7 @@ common testDependencies
          , epo-api-client
          , extra ^>= 1.7.9
          , fast-logger ^>= 3.2.2
          , filepath ^>= 1.4.2.2
          , fmt
          , gargantext
          , gargantext-prelude
          ......@@ -798,6 +800,7 @@ test-suite garg-test-tasty
          CLI.Phylo.Common
          Paths_gargantext
          Test.API.Private.Share
          Test.API.Private.Table
          Test.API.Authentication
          Test.API.Routes
          Test.API.Setup
          ......@@ -836,7 +839,8 @@ test-suite garg-test-tasty
          Test.Server.ReverseProxy
          Test.Types
          Test.Utils
          Test.Utils.Crypto
          Test.Utils.Crypto
          Test.Ngrams.Lang.Occurrences
          Test.Utils.Jobs
          hs-source-dirs:
          test bin/gargantext-cli
          ......@@ -857,6 +861,7 @@ test-suite garg-test-hspec
          Test.API.Notifications
          Test.API.Private
          Test.API.Private.Share
          Test.API.Private.Table
          Test.API.Routes
          Test.API.Setup
          Test.API.UpdateList
          ......
          src/Gargantext/Core/Text/Terms/Mono.hs
          View file @ fff00f20
          ......@@ -33,7 +33,7 @@ words = monoTexts
          -- | Sentence split separators
          isSep :: Char -> Bool
          isSep = (`elem` (",.:;?!(){}[]\"\'" :: String))
          isSep = (`elem` (",.:;?!(){}[]" :: String))
          monoTerms :: Lang -> Text -> [TermsWithCount]
          monoTerms l txt = map (\t -> (monoText2term l t, 1)) $ monoTexts txt
          ......
          src/Gargantext/Core/Text/Terms/Mono/Stem/Internal/GargPorter.hs
          View file @ fff00f20
          {-|
          Module : Gargantext.Core.Text.Ngrams.Stem.En
          Description : Porter Algorithm Implementation purely Haskell
          Copyright : (c) CNRS, 2017-Present
          License : AGPL + CECILL v3
          Maintainer : team@gargantext.org
          Stability : experimental
          Portability : POSIX
          Adapted from:
          - source: https://hackage.haskell.org/package/porter
          - [Char] -> [Text]
          - adding Types signatures
          - fixes unseen cases
          -}
          module Gargantext.Core.Text.Terms.Mono.Stem.Internal.GargPorter (stem)
          where
          import Control.Monad
          import Data.Either
          import Data.List ((!!))
          import Data.List qualified as List hiding (map, head)
          import Data.Maybe
          import Data.Text (pack, unpack)
          import Gargantext.Prelude
          vowels :: [Char]
          vowels = ['a','e','i','o','u']
          isConsonant :: [Char] -> Int -> Bool
          isConsonant str i
          | c `elem` vowels = False
          | c == 'y' = i == 0 || isVowel str (i - 1)
          | otherwise = True
          where
          c = str !! i
          isVowel :: [Char] -> Int -> Bool
          isVowel = (not .) . isConsonant
          byIndex :: Foldable t1 => (t1 a -> [Int] -> t2) -> t1 a -> t2
          byIndex fun str = fun str [0..length str - 1]
          containsVowel :: [Char] -> Bool
          containsVowel = byIndex (any . isVowel)
          -- | /!\ unsafe fromJust
          measure :: [Char] -> Int
          measure = length . filter not . List.init . (True:)
          . map fromJust . map head
          . List.group . byIndex (map . isConsonant)
          endsWithDouble :: [Char] -> Bool
          endsWithDouble = startsWithDouble . reverse
          where
          startsWithDouble l = case l of
          (x:y:_) -> x == y && x `List.notElem` vowels
          _ -> False
          cvc :: [Char] -> Bool
          cvc word | length word < 3 = False
          | otherwise = isConsonant word lastIndex &&
          isVowel word (lastIndex - 1) &&
          isConsonant word (lastIndex - 2) &&
          List.last word `List.notElem` ['w','x','y']
          where lastIndex = length word - 1
          statefulReplace :: Eq a => ([a] -> Bool)
          -> [a] -> [a] -> [a]
          -> Maybe (Data.Either.Either [a] [a])
          statefulReplace predicate str end replacement
          | end `List.isSuffixOf` str = Just replaced
          | otherwise = Nothing
          where
          part = take (length str - length end) str
          replaced | predicate part = Right (part <> replacement)
          | otherwise = Left str
          replaceEnd :: Eq a => ([a] -> Bool) -> [a] -> [a] -> [a] -> Maybe [a]
          replaceEnd predicate str end replacement = do
          result <- statefulReplace predicate str end replacement
          pure (either identity identity result)
          findStem
          :: (Foldable t, Functor t, Eq a) =>
          ([a] -> Bool) -> [a] -> t ([a], [a]) -> Maybe [a]
          findStem f word pairs = msum $ map (uncurry (replaceEnd f word)) pairs
          measureGT :: Int -> [Char] -> Bool
          measureGT = flip ((>) . measure)
          step1a :: [Char] -> [Char]
          step1a word = fromMaybe word result
          where
          result = findStem (const True) word suffixes
          suffixes = [("sses", "ss"), ("ies", "i"), ("ss", "ss"), ("s", "")]
          beforeStep1b :: [Char] -> Either [Char] [Char]
          beforeStep1b word = fromMaybe (Left word) result
          where
          cond23 x = do { v <- x; either (const Nothing) (return . Right) v }
          cond1 x = do { v <- x; pure (Left v) }
          result =
          cond1 (replaceEnd (measureGT 0) word "eed" "ee") `mplus`
          cond23 (statefulReplace containsVowel word "ed" "" ) `mplus`
          cond23 (statefulReplace containsVowel word "ing" "" )
          afterStep1b :: [Char] -> [Char]
          afterStep1b word = fromMaybe word result
          where
          double = endsWithDouble word && not (any ((`List.isSuffixOf` word) . return) ['l','s','z'])
          mEq1AndCvc = measure word == 1 && cvc word
          iif cond val = if cond then Just val else Nothing
          result = findStem (const True) word [("at", "ate"), ("bl", "ble"), ("iz", "ize")]
          `mplus` iif double (List.init word)
          `mplus` iif mEq1AndCvc (word <> "e")
          step1b :: [Char] -> [Char]
          step1b = either identity afterStep1b . beforeStep1b
          step1c :: [Char] -> [Char]
          step1c word = fromMaybe word result
          where result = replaceEnd containsVowel word "y" "i"
          step1 :: [Char] -> [Char]
          step1 = step1c . step1b . step1a
          step2 :: [Char] -> [Char]
          step2 word = fromMaybe word result
          where
          result = findStem (measureGT 0) word
          [ ("ational", "ate" )
          , ("tional", "tion")
          , ("enci", "ence")
          , ("anci", "ance")
          , ("izer", "ize" )
          , ("bli", "ble" )
          , ("alli", "al" )
          , ("entli", "ent" )
          , ("eli", "e" )
          , ("ousli", "ous" )
          , ("ization", "ize" )
          , ("ation", "ate" )
          , ("ator", "ate" )
          , ("alism", "al" )
          , ("iveness", "ive" )
          , ("fulness", "ful" )
          , ("ousness", "ous" )
          , ("aliti", "al" )
          , ("iviti", "ive" )
          , ("biliti", "ble" )
          , ("logi", "log" ) ]
          step3 :: [Char] -> [Char]
          step3 word = fromMaybe word result
          where
          result = findStem (measureGT 0) word
          [ ("icate", "ic")
          , ("ative", "" )
          , ("alize", "al")
          , ("iciti", "ic")
          , ("ical" , "ic")
          , ("ful" , "" )
          , ("ness" , "" ) ]
          step4 :: [Char] -> [Char]
          step4 word = fromMaybe word result
          where
          gt1andST str = (measureGT 1) str && any ((`List.isSuffixOf` str) . return) ['s','t']
          findGT1 = findStem (measureGT 1) word . map (flip (,) "")
          result = (findGT1 ["al", "ance", "ence", "er", "ic", "able", "ible", "ant", "ement", "ment", "ent"]) `mplus`
          (findStem gt1andST word [("ion","")]) `mplus`
          (findGT1 ["ou", "ism", "ate", "iti", "ous", "ive", "ize"])
          step5a :: [Char] -> [Char]
          step5a word = fromMaybe word result
          where
          test str = (measureGT 1 str) || ((measure str == 1) && (not $ cvc str))
          result = replaceEnd test word "e" ""
          step5b :: [Char] -> [Char]
          step5b word = fromMaybe word result
          where
          cond s = List.last s == 'l' && measureGT 1 s
          result = replaceEnd cond word "l" ""
          step5 :: [Char] -> [Char]
          step5 = step5b . step5a
          allSteps :: [Char] -> [Char]
          allSteps = step5 . step4 . step3 . step2 . step1
          stem :: Text -> Text
          stem s = pack (stem' $ unpack s)
          stem' :: [Char] -> [Char]
          stem' s | length s < 3 = s
          | otherwise = allSteps s
          --fixpoint :: Eq t => (t -> t) -> t -> t
          --fixpoint f x = let fx = f x in
          -- if fx == x
          -- then x
          -- else fixpoint f fx
          --
          --fixstem :: [Char] -> [Char]
          --fixstem = fixpoint stem'
          {-
          main :: IO ()
          main = do
          content <- readFile "input.txt"
          writeFile "output.txt" $ unlines $ map stem $ lines content
          -}
          {-|
          Module : Gargantext.Core.Text.Ngrams.Stem.En
          Description : Porter Algorithm Implementation purely Haskell
          Copyright : (c) CNRS, 2017-Present
          License : AGPL + CECILL v3
          Maintainer : team@gargantext.org
          Stability : experimental
          Portability : POSIX
          Adapted from:
          - source: https://hackage.haskell.org/package/porter
          - [Char] -> [Text]
          - adding Types signatures
          - fixes unseen cases
          -}
          module Gargantext.Core.Text.Terms.Mono.Stem.Internal.GargPorter (stem)
          where
          import Control.Monad
          import Data.Either
          import Data.List ((!!))
          import Data.List qualified as List hiding (map, head)
          import Data.Maybe
          import Data.Text (pack, unpack)
          import Gargantext.Prelude
          vowels :: [Char]
          vowels = ['a','e','i','o','u']
          isConsonant :: [Char] -> Int -> Bool
          isConsonant str i
          | c `elem` vowels = False
          | c == 'y' = i == 0 || isVowel str (i - 1)
          | otherwise = True
          where
          c = str !! i
          isVowel :: [Char] -> Int -> Bool
          isVowel = (not .) . isConsonant
          byIndex :: Foldable t1 => (t1 a -> [Int] -> t2) -> t1 a -> t2
          byIndex fun str = fun str [0..length str - 1]
          containsVowel :: [Char] -> Bool
          containsVowel = byIndex (any . isVowel)
          -- | /!\ unsafe fromJust
          measure :: [Char] -> Int
          measure = length . filter not . List.init . (True:)
          . map fromJust . map head
          . List.group . byIndex (map . isConsonant)
          endsWithDouble :: [Char] -> Bool
          endsWithDouble = startsWithDouble . reverse
          where
          startsWithDouble l = case l of
          (x:y:_) -> x == y && x `List.notElem` vowels
          _ -> False
          cvc :: [Char] -> Bool
          cvc word | length word < 3 = False
          | otherwise = isConsonant word lastIndex &&
          isVowel word (lastIndex - 1) &&
          isConsonant word (lastIndex - 2) &&
          List.last word `List.notElem` ['w','x','y']
          where lastIndex = length word - 1
          statefulReplace :: Eq a => ([a] -> Bool)
          -> [a] -> [a] -> [a]
          -> Maybe (Data.Either.Either [a] [a])
          statefulReplace predicate str end replacement
          | end `List.isSuffixOf` str = Just replaced
          | otherwise = Nothing
          where
          part = take (length str - length end) str
          replaced | predicate part = Right (part <> replacement)
          | otherwise = Left str
          replaceEnd :: Eq a => ([a] -> Bool) -> [a] -> [a] -> [a] -> Maybe [a]
          replaceEnd predicate str end replacement = do
          result <- statefulReplace predicate str end replacement
          pure (either identity identity result)
          findStem
          :: (Foldable t, Functor t, Eq a) =>
          ([a] -> Bool) -> [a] -> t ([a], [a]) -> Maybe [a]
          findStem f word pairs = msum $ map (uncurry (replaceEnd f word)) pairs
          measureGT :: Int -> [Char] -> Bool
          measureGT = flip ((>) . measure)
          step1a :: [Char] -> [Char]
          step1a word = fromMaybe word result
          where
          result = findStem (const True) word suffixes
          suffixes = [("sses", "ss"), ("ies", "i"), ("ss", "ss"), ("s", "")]
          beforeStep1b :: [Char] -> Either [Char] [Char]
          beforeStep1b word = fromMaybe (Left word) result
          where
          cond23 x = do { v <- x; either (const Nothing) (return . Right) v }
          cond1 x = do { v <- x; pure (Left v) }
          result =
          cond1 (replaceEnd (measureGT 0) word "eed" "ee") `mplus`
          cond23 (statefulReplace containsVowel word "ed" "" ) `mplus`
          cond23 (statefulReplace containsVowel word "ing" "" )
          afterStep1b :: [Char] -> [Char]
          afterStep1b word = fromMaybe word result
          where
          double = endsWithDouble word && not (any ((`List.isSuffixOf` word) . return) ['l','s','z'])
          mEq1AndCvc = measure word == 1 && cvc word
          iif cond val = if cond then Just val else Nothing
          result = findStem (const True) word [("at", "ate"), ("bl", "ble"), ("iz", "ize")]
          `mplus` iif double (List.init word)
          `mplus` iif mEq1AndCvc (word <> "e")
          step1b :: [Char] -> [Char]
          step1b = either identity afterStep1b . beforeStep1b
          -- Issue #415: According to the Porter stemming rules, we need to replace `y` with `i` only if there
          -- are no other vocals at the end.
          step1c :: [Char] -> [Char]
          step1c word
          | length word > 2 && List.last word == 'y' && isConsonant word (List.length word - 2)
          = List.init word <> "i"
          | otherwise
          = word
          step1 :: [Char] -> [Char]
          step1 = step1c . step1b . step1a
          step2 :: [Char] -> [Char]
          step2 word = fromMaybe word result
          where
          result = findStem (measureGT 0) word
          [ ("ational", "ate" )
          , ("tional", "tion")
          , ("enci", "ence")
          , ("anci", "ance")
          , ("izer", "ize" )
          , ("bli", "ble" )
          , ("alli", "al" )
          , ("entli", "ent" )
          , ("eli", "e" )
          , ("ousli", "ous" )
          , ("ization", "ize" )
          , ("ation", "ate" )
          , ("ator", "ate" )
          , ("alism", "al" )
          , ("iveness", "ive" )
          , ("fulness", "ful" )
          , ("ousness", "ous" )
          , ("aliti", "al" )
          , ("iviti", "ive" )
          , ("biliti", "ble" )
          , ("logi", "log" ) ]
          step3 :: [Char] -> [Char]
          step3 word = fromMaybe word result
          where
          result = findStem (measureGT 0) word
          [ ("icate", "ic")
          , ("ative", "" )
          , ("alize", "al")
          , ("iciti", "ic")
          , ("ical" , "ic")
          , ("ful" , "" )
          , ("ness" , "" ) ]
          step4 :: [Char] -> [Char]
          step4 word = fromMaybe word result
          where
          gt1andST str = (measureGT 1) str && any ((`List.isSuffixOf` str) . return) ['s','t']
          findGT1 = findStem (measureGT 1) word . map (flip (,) "")
          result = (findGT1 ["al", "ance", "ence", "er", "ic", "able", "ible", "ant", "ement", "ment", "ent"]) `mplus`
          (findStem gt1andST word [("ion","")]) `mplus`
          (findGT1 ["ou", "ism", "ate", "iti", "ous", "ive", "ize"])
          step5a :: [Char] -> [Char]
          step5a word = fromMaybe word result
          where
          test str = (measureGT 1 str) || ((measure str == 1) && (not $ cvc str))
          result = replaceEnd test word "e" ""
          step5b :: [Char] -> [Char]
          step5b word = fromMaybe word result
          where
          cond s = List.last s == 'l' && measureGT 1 s
          result = replaceEnd cond word "l" ""
          step5 :: [Char] -> [Char]
          step5 = step5b . step5a
          allSteps :: [Char] -> [Char]
          allSteps = step5 . step4 . step3 . step2 . step1
          stem :: Text -> Text
          stem s = pack (stem' $ unpack s)
          stem' :: [Char] -> [Char]
          stem' s | length s < 3 = s
          | otherwise = allSteps s
          --fixpoint :: Eq t => (t -> t) -> t -> t
          --fixpoint f x = let fx = f x in
          -- if fx == x
          -- then x
          -- else fixpoint f fx
          --
          --fixstem :: [Char] -> [Char]
          --fixstem = fixpoint stem'
          {-
          main :: IO ()
          main = do
          content <- readFile "input.txt"
          writeFile "output.txt" $ unlines $ map stem $ lines content
          -}
          test-data/phylo/187481.json
          View file @ fff00f20
          This source diff could not be displayed because it is too large. You can view the blob instead.
          test-data/phylo/cleopatre.golden.json
          View file @ fff00f20
          This source diff could not be displayed because it is too large. You can view the blob instead.
          test-data/phylo/nadal.golden.json
          View file @ fff00f20
          This source diff could not be displayed because it is too large. You can view the blob instead.
          test-data/phylo/phylo2dot2json.golden.json
          View file @ fff00f20
          This source diff could not be displayed because it is too large. You can view the blob instead.
          test-data/search/GarganText_DocsList-soysauce.json 0 → 100644
          View file @ fff00f20
          {
          "documents": [
          {
          "document": {
          "id": 1101563,
          "hash_id": null,
          "typename": 4,
          "user_id": 58,
          "parent_id": null,
          "name": "THE EFFECT OF ANTIOXIDANTS ON FROZEN GROUND PORK",
          "date": "1956-01-01T00:00:00Z",
          "hyperdata": {
          "abstract": "The relative effectiveness of monosodium glutamate (MSG), soybean flour, and butylated hydroxyanisole (BHA) as antioxidants for ground pork stored raw, and pork cooked prior to freezer storage, was studied. Peroxide determinations were made at intervals through 18 months of storage, and organoleptic judgments at corresponding intervals through 12 months. Peroxide determinations indicated that soybean flour, BHA, and the cooking process alone inhibited fat oxidation, but MSG did not. On palatability tests, soy-treated pork was rated down on flavor. Samples with MSG received the best scores, but showed rapid peroxide development after 12 months when stored raw. None of the samples became rancid during the first 12 months of storage. At 15 and 18 months, peroxide numbers indicated rancidity in the untreated and in the MSG treated pork stored raw.",
          "authors": "NEILL, J; PAGE, L",
          "bdd": "WOS",
          "language_iso2": "EN",
          "publication_date": "1956-01-01 00:00:00 UTC",
          "publication_day": 1,
          "publication_month": 1,
          "publication_year": 1956,
          "source": "FOOD TECHNOLOGY",
          "title": "THE EFFECT OF ANTIOXIDANTS ON FROZEN GROUND PORK"
          }
          },
          "ngrams": {
          "ngrams": [],
          "hash": ""
          },
          "hash": ""
          },
          {
          "document": {
          "id": 1101539,
          "hash_id": null,
          "typename": 4,
          "user_id": 58,
          "parent_id": null,
          "name": "INFLUENCE OF DIETARY PROTEIN LEVEL AND AMINO ACID COMPOSITION ON CHICK; PERFORMANCE",
          "date": "1965-01-01T00:00:00Z",
          "hyperdata": {
          "abstract": "Studies were designed to investigate the effects of altering dietary protein levels and/or amino acid composition on chick growth and feed efficiency. Contradictory observations in chick performance were made among a series of diets in which the crude protein content was increased from 18 to 22%. Chick weight and feed efficiency was unaffected as dietary protein was increased by replacing cellulose with monosodium glutamate or L-glutamic acid. Chick performance was improved, however, by supplementation of the deficient essential amino acids. Increasing dietary protein concomitantly with essential amino acid supplementation had no effect on chick weight or feed efficiency. In contrast, significant improvements in chick performance were observed in a series of diets where dietary protein was increased by replacing corn with soybean meal.",
          "authors": "ASKELSON, CE; BALLOUN, SL",
          "bdd": "WOS",
          "doi": "10.3382/ps.0440193",
          "language_iso2": "EN",
          "publication_date": "1965-01-01 00:00:00 UTC",
          "publication_day": 1,
          "publication_month": 1,
          "publication_year": 1965,
          "source": "POULTRY SCIENCE",
          "title": "INFLUENCE OF DIETARY PROTEIN LEVEL AND AMINO ACID COMPOSITION ON CHICK; PERFORMANCE"
          }
          },
          "ngrams": {
          "ngrams": [],
          "hash": ""
          },
          "hash": ""
          },
          {
          "document": {
          "id": 1102103,
          "hash_id": null,
          "typename": 4,
          "user_id": 58,
          "parent_id": null,
          "name": "DILUENT SENSITIVITY IN THERMALLY STRESSED CELLS OF; PSEUDOMONAS-FLUORESCENS",
          "date": "1977-01-01T00:00:00Z",
          "hyperdata": {
          "abstract": "Thermally injured cells of P. fluorescens cannot produce colonies on Trypticase soy agar (TSA) after dilution with 0.1% peptone. Nutritional exigency could not be used as the criterion for this injury, since varying the composition of the plating medium had little effect on the number of colonies that developed. The injured cells had no requirement for compounds known to leak out during the heat treatment in order to recover. The cells did not exhibit injury if dilution preceded heat treatment on the plating medium, demonstrating that the heat treatment sensitized the cells to the trauma of dilution. Substitution of 0.1% peptone with growth medium as the diluent largely offset the previously observed drop in TSA count. Little difference in survival was observed when monosodium glutamate or the balance of the defined medium was used as the diluent. The diluent effect was ionic rather than osmotic. The presence of cations was important in maintaining the integrity of the injured cell, and divalent cations enhanced this protective effect. The role of these cations at the level of the cell envelope is discussed.",
          "authors": "GRAY, RJH; ORDAL, ZJ; WITTER, LD",
          "bdd": "WOS",
          "doi": "10.1128/AEM.33.5.1074-1078.1977",
          "language_iso2": "EN",
          "publication_date": "1977-01-01 00:00:00 UTC",
          "publication_day": 1,
          "publication_month": 1,
          "publication_year": 1977,
          "source": "APPLIED AND ENVIRONMENTAL MICROBIOLOGY",
          "title": "DILUENT SENSITIVITY IN THERMALLY STRESSED CELLS OF; PSEUDOMONAS-FLUORESCENS"
          }
          },
          "ngrams": {
          "ngrams": [],
          "hash": ""
          },
          "hash": ""
          },
          {
          "document": {
          "id": 1101179,
          "hash_id": null,
          "typename": 4,
          "user_id": 58,
          "parent_id": null,
          "name": "GROWTH OF BACILLUS-CEREUS IN MEDIA CONTAINING PLANT SEED MATERIALS AND; INGREDIENTS USED IN CHINESE COOKERY",
          "date": "1980-01-01T00:00:00Z",
          "hyperdata": {
          "abstract": "Growth and sporulation of enterotoxigenic strains of B. cereus in media containing 20 different plant seed flours and meals, with and without added infusions of beef, pork, chicken and shrimp, monosodium glutamate (MSG) and soy sauce, were studied. Suspensions (2%; pH 7.1) of seed flours and meals from diverse botanical origins were excellent sources of nutrients for growth. No correlations could be made between composition of seed materials and rate of cell division. Mean generation times of B. cereus cultured in soy, peanut and rice flour media supplemented with animal flesh infusions were significantly faster (P .ltoreq. 0.05) than those of respective controls. Monosodium glutamate (1-2%) and soy sauce (5-10%) stimulated the rate of growth of B. cereus in rice flour medium. Test flours supporting slower growth rates appeared generally to support higher rates of sporulation.",
          "authors": "BEUCHAT, LR; MALIN, CFA; CARPENTER, JA",
          "bdd": "WOS",
          "doi": "10.1111/j.1365-2672.1980.tb01028.x",
          "language_iso2": "EN",
          "publication_date": "1980-01-01 00:00:00 UTC",
          "publication_day": 1,
          "publication_month": 1,
          "publication_year": 1980,
          "source": "JOURNAL OF APPLIED BACTERIOLOGY",
          "title": "GROWTH OF BACILLUS-CEREUS IN MEDIA CONTAINING PLANT SEED MATERIALS AND; INGREDIENTS USED IN CHINESE COOKERY"
          }
          },
          "ngrams": {
          "ngrams": [],
          "hash": ""
          },
          "hash": ""
          }
          ],
          "garg_version": "0.0.7.3.1"
          }
          test/Test/API/Authentication.hs
          View file @ fff00f20
          ......@@ -20,7 +20,7 @@ import Prelude qualified
          import Servant.Auth.Client ()
          import Servant.Client
          import Test.API.Routes (auth_api)
          import Test.API.Setup (withTestDBAndPort, setupEnvironment)
          import Test.API.Setup (withTestDBAndPort, setupEnvironment, SpecContext (..))
          import Test.Database.Types
          import Test.Hspec
          import Gargantext.API.Routes.Named
          ......@@ -32,7 +32,7 @@ cannedToken = "eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsiaWQiOjF9fQ.t49zZSqkPAulEkYEh4pW1
          tests :: Spec
          tests = sequential $ aroundAll withTestDBAndPort $ do
          describe "Prelude" $ do
          it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
          it "setup DB triggers" $ \SpecContext{..} -> setupEnvironment _sctx_env
          describe "Authentication" $ do
          baseUrl <- runIO $ parseBaseUrl "http://localhost"
          manager <- runIO $ newManager defaultManagerSettings
          ......@@ -41,15 +41,15 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          -- testing scenarios start here
          describe "GET /api/v1.0/version" $ do
          let version_api = gargVersionEp . gargAPIVersion . mkBackEndAPI $ genericClient
          it "requires no auth and returns the current version" $ \((_testEnv, port), _) -> do
          result <- runClientM version_api (clientEnv port)
          it "requires no auth and returns the current version" $ \SpecContext{..} -> do
          result <- runClientM version_api (clientEnv _sctx_port)
          case result of
          Left err -> Prelude.fail (show err)
          Right r -> r `shouldSatisfy` ((>= 1) . T.length) -- we got something back
          describe "POST /api/v1.0/auth" $ do
          it "requires no auth and authenticates the user 'alice'" $ \((testEnv, port), _) -> do
          it "requires no auth and authenticates the user 'alice'" $ \(SpecContext testEnv port _app _) -> do
          -- Let's create the Alice user.
          void $ flip runReaderT testEnv $ runTestMonad $ do
          ......@@ -66,7 +66,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          result `shouldBe` Right expected
          it "denies login for user 'alice' if password is invalid" $ \((_testEnv, port), _) -> do
          it "denies login for user 'alice' if password is invalid" $ \(SpecContext _testEnv port _app _) -> do
          let authPayload = AuthRequest "alice" (GargPassword "wrong")
          result <- runClientM (auth_api authPayload) (clientEnv port)
          putText $ "result: " <> show result
          ......
          test/Test/API/Errors.hs
          View file @ fff00f20
          ......@@ -15,7 +15,7 @@ import Servant.Auth.Client ()
          import Servant.Client
          import Servant.Client.Generic (genericClient)
          import Test.API.Routes (mkUrl)
          import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
          import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob, SpecContext (..))
          import Test.Hspec
          import Test.Hspec.Wai.Internal (withApplication)
          import Test.Utils (protected, withValidLogin, protectedNewError)
          ......@@ -26,7 +26,7 @@ tests :: Spec
          tests = sequential $ aroundAll withTestDBAndPort $ do
          describe "Errors API" $ do
          describe "Prelude" $ do
          it "setup DB triggers and users" $ \((testEnv, port), _) -> do
          it "setup DB triggers and users" $ \(SpecContext testEnv port _app _) -> do
          setupEnvironment testEnv
          baseUrl <- parseBaseUrl "http://localhost"
          manager <- newManager defaultManagerSettings
          ......@@ -41,7 +41,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          describe "GET /api/v1.0/node" $ do
          it "returns the old error by default" $ \((_testEnv, port), app) -> do
          it "returns the old error by default" $ \(SpecContext _testEnv port app _) -> do
          withApplication app $ do
          withValidLogin port "gargantua" (GargPassword "secret_key") $ \_clientEnv token -> do
          res <- protected token "GET" (mkUrl port "/node/99") ""
          ......@@ -52,7 +52,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          statusCode `shouldBe` 404
          simpleBody `shouldBe` [r|{"error":"Node does not exist","node":99}|]
          it "returns the new error if header X-Garg-Error-Scheme: new is passed" $ \((_testEnv, port), app) -> do
          it "returns the new error if header X-Garg-Error-Scheme: new is passed" $ \(SpecContext _testEnv port app _) -> do
          withApplication app $ do
          withValidLogin port "gargantua" (GargPassword "secret_key") $ \_clientEnv token -> do
          res <- protectedNewError token "GET" (mkUrl port "/node/99") ""
          ......
          test/Test/API/GraphQL.hs
          View file @ fff00f20
          ......@@ -10,7 +10,7 @@ module Test.API.GraphQL (
          import Gargantext.Core.Types.Individu
          import Prelude
          import Servant.Auth.Client ()
          import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
          import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob, SpecContext (..))
          import Test.Hspec
          import Test.Hspec.Wai.Internal (withApplication)
          import Test.Hspec.Wai.JSON (json)
          ......@@ -21,10 +21,10 @@ tests :: Spec
          tests = sequential $ aroundAll withTestDBAndPort $ do
          describe "GraphQL" $ do
          describe "Prelude" $ do
          it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
          it "setup DB triggers" $ \SpecContext{..} -> setupEnvironment _sctx_env
          describe "get_user_infos" $ do
          it "allows 'alice' to see her own info" $ \((testEnv, port), app) -> do
          it "allows 'alice' to see her own info" $ \(SpecContext testEnv port app _) -> do
          createAliceAndBob testEnv
          withApplication app $ do
          ......@@ -34,7 +34,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          protected token "POST" "/gql" query `shouldRespondWithFragment` expected
          describe "nodes" $ do
          it "returns node_type" $ \((_testEnv, port), app) -> do
          it "returns node_type" $ \(SpecContext _testEnv port app _) -> do
          withApplication app $ do
          withValidLogin port "gargantua" (GargPassword "secret_key") $ \_clientEnv token -> do
          let query = [r| { "query": "{ nodes(node_id: 2) { node_type } }" } |]
          ......@@ -42,21 +42,21 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          protected token "POST" "/gql" query `shouldRespondWithFragment` expected
          describe "check error format" $ do
          it "returns the new error if header X-Garg-Error-Scheme: new is passed" $ \((_testEnv, port), app) -> do
          it "returns the new error if header X-Garg-Error-Scheme: new is passed" $ \(SpecContext _testEnv port app _) -> do
          withApplication app $ do
          withValidLogin port "gargantua" (GargPassword "secret_key") $ \_clientEnv token -> do
          let query = [r| { "query": "{ languages(id:5) { lt_lang } }" } |]
          let expected = [json| {"errors": [{"locations":[{"column":13,"line":1}],"message":"Unknown Argument \"id\" on Field \"languages\"."}] } |]
          protectedNewError token "POST" "/gql" query `shouldRespondWithFragment` expected
          it "returns the old error (though this is deprecated)" $ \((_testEnv, port), app) -> do
          it "returns the old error (though this is deprecated)" $ \(SpecContext _testEnv port app _) -> do
          withApplication app $ do
          withValidLogin port "gargantua" (GargPassword "secret_key") $ \_clientEnv token -> do
          let query = [r| { "query": "{ languages(id:5) { lt_lang } }" } |]
          let expected = [json| {"errors": [{"locations":[{"column":13,"line":1}],"message":"Unknown Argument \"id\" on Field \"languages\"."}] } |]
          protected token "POST" "/gql" query `shouldRespondWithFragment` expected
          it "check new errors with 'type'" $ \((_testEnv, port), app) -> do
          it "check new errors with 'type'" $ \(SpecContext _testEnv port app _) -> do
          withApplication app $ do
          withValidLogin port "gargantua" (GargPassword "secret_key") $ \_clientEnv token -> do
          let query = [r| { "query": "mutation { delete_team_membership(shared_folder_id:1, team_node_id:1, token:\"abc\") }" } |]
          ......
          test/Test/API/Private.hs
          View file @ fff00f20
          ......@@ -9,26 +9,25 @@ module Test.API.Private (
          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 (Node)
          import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
          import Gargantext.Prelude hiding (get)
          import Network.HTTP.Client hiding (Proxy)
          import Network.Wai
          import Servant.Auth.Client ()
          import Servant.Client
          import Servant.Client.Generic (genericClient)
          import Test.API.Private.Share qualified as Share
          import Test.API.Private.Table qualified as Table
          import Test.API.Routes (mkUrl)
          import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
          import Test.Database.Types
          import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob, SpecContext (..))
          import Test.Hspec
          import Test.Hspec.Wai hiding (pendingWith)
          import Test.Hspec.Wai.Internal (withApplication)
          import Test.Hspec.Wai.JSON (json)
          import Test.Utils (protected, shouldRespondWithFragment, withValidLogin)
          privateTests :: SpecWith ((TestEnv, Int), Application)
          privateTests :: SpecWith (SpecContext a)
          privateTests =
          describe "Private API" $ do
          baseUrl <- runIO $ parseBaseUrl "http://localhost"
          ......@@ -38,7 +37,7 @@ privateTests =
          describe "GET /api/v1.0/user" $ do
          -- FIXME(adn): unclear if this is useful at all. Doesn't do permission checking.
          it "doesn't allow someone with an invalid token to show the results" $ \((testEnv, port), _) -> do
          it "doesn't allow someone with an invalid token to show the results" $ \(SpecContext testEnv port _ _) -> do
          createAliceAndBob testEnv
          ......@@ -49,7 +48,7 @@ privateTests =
          length result `shouldBe` 0
          -- FIXME(adn): unclear if this is useful at all. Doesn't do permission checking.
          it "allows 'alice' to see the results" $ \((_testEnv, port), _) -> do
          it "allows 'alice' to see the results" $ \(SpecContext _testEnv port _app _) -> do
          withValidLogin port "alice" (GargPassword "alice") $ \clientEnv _token -> do
          let gargAdminClient = (genericClient :: GargAdminAPI (AsClientT ClientM))
          ......@@ -60,33 +59,33 @@ privateTests =
          describe "GET /api/v1.0/node" $ do
          it "unauthorised users shouldn't see anything" $ \((_testEnv, port), app) -> do
          it "unauthorised users shouldn't see anything" $ \(SpecContext _testEnv port app _) -> do
          withApplication app $ do
          get (mkUrl port "/node/1") `shouldRespondWith` 401
          it "allows 'alice' to see her own node info" $ \((_testEnv, port), app) -> do
          it "allows 'alice' to see her own node info" $ \(SpecContext _testEnv port app _) -> do
          withApplication app $ do
          withValidLogin port "alice" (GargPassword "alice") $ \_clientEnv token -> do
          protected token "GET" (mkUrl port "/node/8") ""
          `shouldRespondWithFragment` [json| {"id":8,"user_id":2,"name":"alice" } |]
          it "forbids 'alice' to see others node private info" $ \((_testEnv, port), app) -> do
          it "forbids 'alice' to see others node private info" $ \(SpecContext _testEnv port app _) -> do
          withApplication app $ do
          withValidLogin port "alice" (GargPassword "alice") $ \_clientEnv token -> do
          protected token "GET" (mkUrl port "/node/1") "" `shouldRespondWith` 403
          describe "GET /api/v1.0/tree" $ do
          it "unauthorised users shouldn't see anything" $ \((_testEnv, port), app) -> do
          it "unauthorised users shouldn't see anything" $ \(SpecContext _testEnv port app _) -> do
          withApplication app $ do
          get (mkUrl port "/tree/1") `shouldRespondWith` 401
          it "allows 'alice' to see her own node info" $ \((_testEnv, port), app) -> do
          it "allows 'alice' to see her own node info" $ \(SpecContext _testEnv port app _) -> do
          withApplication app $ do
          withValidLogin port "alice" (GargPassword "alice") $ \_clientEnv token -> do
          protected token "GET" (mkUrl port "/tree/8") ""
          `shouldRespondWithFragment` [json| { "node": {"id":8, "name":"alice", "type": "NodeUser" } } |]
          it "forbids 'alice' to see others node private info" $ \((_testEnv, port), app) -> do
          it "forbids 'alice' to see others node private info" $ \(SpecContext _testEnv port app _) -> do
          withApplication app $ do
          withValidLogin port "alice" (GargPassword "alice") $ \_clientEnv token -> do
          protected token "GET" (mkUrl port "/tree/1") "" `shouldRespondWith` 403
          ......@@ -96,7 +95,9 @@ tests :: Spec
          tests = do
          sequential $ aroundAll withTestDBAndPort $ do
          describe "Prelude" $ do
          it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
          it "setup DB triggers" $ \SpecContext{..} -> setupEnvironment _sctx_env
          privateTests
          describe "Share API" $ do
          Share.tests
          describe "Table API" $ do
          Table.tests
          test/Test/API/Private/Share.hs
          View file @ fff00f20
          ......@@ -43,12 +43,12 @@ shareURL token =
          tests :: Spec
          tests = sequential $ aroundAll withTestDBAndPort $ do
          describe "Prelude" $ do
          it "setup DB triggers" $ \((testEnv, _), _) -> do
          setupEnvironment testEnv
          it "setup DB triggers" $ \SpecContext{..} -> do
          setupEnvironment _sctx_env
          -- Let's create the Alice user.
          createAliceAndBob testEnv
          createAliceAndBob _sctx_env
          it "should fail if no node type is specified" $ \((_testEnv, serverPort), app) -> do
          it "should fail if no node type is specified" $ \(SpecContext _testEnv serverPort app _) -> do
          withApplication app $ do
          withValidLogin serverPort "alice" (GargPassword "alice") $ \clientEnv token -> do
          url <- liftIO $ runClientM (shareURL (toServantToken token) Nothing Nothing) clientEnv
          ......@@ -57,7 +57,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          -> 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
          it "should fail if no node ID is specified" $ \(SpecContext _testEnv serverPort app _) -> do
          withApplication app $ do
          withValidLogin serverPort "alice" (GargPassword "alice") $ \clientEnv token -> do
          url <- liftIO $ runClientM (shareURL (toServantToken token) (Just NodeCorpus) Nothing) clientEnv
          ......@@ -66,7 +66,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          -> 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
          it "should return a valid URL" $ \(SpecContext testEnv serverPort app _) -> do
          withApplication app $ do
          withValidLogin serverPort "alice" (GargPassword "alice") $ \clientEnv token -> do
          cId <- liftIO $ newCorpusForUser testEnv "alice"
          ......@@ -77,7 +77,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          Right (ShareLink _)
          -> pure ()
          it "should include the port if needed (like localhost)" $ \((testEnv, serverPort), app) -> do
          it "should include the port if needed (like localhost)" $ \(SpecContext testEnv serverPort app _) -> do
          withApplication app $ do
          withValidLogin serverPort "alice" (GargPassword "alice") $ \clientEnv token -> do
          cId <- liftIO $ newCorpusForUser testEnv "alice"
          ......
          test/Test/API/Private/Table.hs 0 → 100644
          View file @ fff00f20
          {-# LANGUAGE BangPatterns #-}
          {-# LANGUAGE TypeApplications #-}
          {-# LANGUAGE TypeFamilies #-}
          module Test.API.Private.Table (
          tests
          ) where
          import Gargantext.API.HashedResponse
          import Gargantext.Core.Text.Corpus.Query
          import Gargantext.Core.Types
          import Gargantext.Core.Types.Individu
          import Gargantext.Prelude
          import qualified Gargantext.API.Ngrams.Types as APINgrams
          import qualified Gargantext.Database.Query.Facet as Facet
          import Servant.Client
          import Test.API.Routes
          import Test.API.Setup
          import Test.API.UpdateList (createDocsList, checkEither)
          import Test.Hspec
          import Test.Hspec.Wai.Internal (withApplication)
          import Test.Utils
          tests :: Spec
          tests = sequential $ aroundAll withTestDBAndPort $ do
          describe "Prelude" $ do
          it "setup DB triggers" $ \SpecContext{..} -> do
          setupEnvironment _sctx_env
          -- Let's create the Alice user.
          createAliceAndBob _sctx_env
          beforeAllWith createSoySauceCorpus $ do
          it "should return sauce in the search (#415)" $ \SpecContext{..} -> do
          let corpusId = _sctx_data
          withApplication _sctx_app $ do
          withValidLogin _sctx_port "alice" (GargPassword "alice") $ \clientEnv token -> do
          liftIO $ do
          (HashedResponse _ tr1)
          <- checkEither $ runClientM (get_table token
          corpusId
          (Just APINgrams.Docs)
          (Just 10)
          (Just 0)
          (Just Facet.DateDesc)
          (Just $ RawQuery "sauce")
          Nothing
          ) clientEnv
          length (tr_docs tr1) `shouldBe` 1
          it "should return soy in the search (#415)" $ \SpecContext{..} -> do
          let corpusId = _sctx_data
          withApplication _sctx_app $ do
          withValidLogin _sctx_port "alice" (GargPassword "alice") $ \clientEnv token -> do
          liftIO $ do
          (HashedResponse _ tr1)
          <- checkEither $ runClientM (get_table token
          corpusId
          (Just APINgrams.Docs)
          (Just 10)
          (Just 0)
          (Just Facet.DateDesc)
          (Just $ RawQuery "soy")
          Nothing
          ) clientEnv
          length (tr_docs tr1) `shouldBe` 3
          createSoySauceCorpus :: SpecContext () -> IO (SpecContext CorpusId)
          createSoySauceCorpus ctx@SpecContext{..} = do
          withApplication _sctx_app $ do
          withValidLogin _sctx_port "alice" (GargPassword "alice") $ \clientEnv token -> do
          corpusId <- createDocsList "test-data/search/GarganText_DocsList-soysauce.json" _sctx_env _sctx_port clientEnv token
          pure $ const corpusId <$> ctx
          test/Test/API/Setup.hs
          View file @ fff00f20
          {-# LANGUAGE BangPatterns #-}
          module Test.API.Setup where
          module Test.API.Setup (
          SpecContext(..)
          , withTestDBAndPort
          , withTestDBAndNotifications
          , withBackendServerAndProxy
          , setupEnvironment
          , createAliceAndBob
          ) where
          import Control.Concurrent.Async qualified as Async
          import Control.Concurrent.MVar
          ......@@ -51,6 +58,21 @@ import Test.Database.Types
          import UnliftIO qualified
          -- | The context that each spec will be carrying along. This type is
          -- polymorphic so that each test can embellish it with test-specific data.
          -- 'SpecContext' is a functor, so you can use 'fmap' to change the 'a'.
          data SpecContext a =
          SpecContext {
          _sctx_env :: !TestEnv
          , _sctx_port :: !Warp.Port
          , _sctx_app :: !Application
          , _sctx_data :: !a
          }
          instance Functor SpecContext where
          fmap f (SpecContext e p a d) = SpecContext e p a (f d)
          newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port -> IO Env
          newTestEnv testEnv logger port = do
          tomlFile@(SettingsFile sf) <- fakeTomlPath
          ......@@ -94,7 +116,7 @@ newTestEnv testEnv logger port = do
          -- | Run the gargantext server on a random port, picked by Warp, which allows
          -- for concurrent tests to be executed in parallel, if we need to.
          withTestDBAndPort :: (((TestEnv, Warp.Port), Application) -> IO ()) -> IO ()
          withTestDBAndPort :: (SpecContext () -> IO ()) -> IO ()
          withTestDBAndPort action =
          withTestDB $ \testEnv -> do
          -- TODO Despite being cautious here only to start/kill dispatcher
          ......@@ -123,7 +145,7 @@ withTestDBAndPort action =
          env <- newTestEnv testEnv ioLogger 8080
          makeApp env
          let stgs = Warp.defaultSettings { settingsOnExceptionResponse = showDebugExceptions }
          Warp.testWithApplicationSettings stgs (pure app) $ \port -> action ((testEnv, port), app)
          Warp.testWithApplicationSettings stgs (pure app) $ \port -> action (SpecContext testEnv port app ())
          withTestDBAndNotifications :: D.Dispatcher -> (((TestEnv, Warp.Port), Application) -> IO ()) -> IO ()
          withTestDBAndNotifications dispatcher action = do
          ......
          test/Test/API/UpdateList.hs
          View file @ fff00f20
          ......@@ -7,12 +7,14 @@
          module Test.API.UpdateList (
          tests
          , newCorpusForUser
          -- * Useful helpers
          , JobPollHandle(..)
          , newCorpusForUser
          , pollUntilFinished
          -- * Useful helpers
          , updateNode
          , createDocsList
          , checkEither
          ) where
          import Control.Lens (mapped, over)
          ......@@ -57,11 +59,12 @@ import Gargantext.Prelude hiding (get)
          import Network.Wai.Handler.Warp qualified as Wai
          import Paths_gargantext (getDataFileName)
          import qualified Prelude
          import System.FilePath
          import Servant
          import Servant.Client
          import Servant.Job.Async
          import Test.API.Routes (mkUrl, gqlUrl, get_table_ngrams, put_table_ngrams, toServantToken, clientRoutes, get_table, update_node)
          import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
          import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob, SpecContext (..))
          import Test.Database.Types
          import Test.Hspec
          import Test.Hspec.Wai.Internal (withApplication, WaiSession)
          ......@@ -114,13 +117,13 @@ uploadJSONList port token cId pathToNgrams = do
          tests :: Spec
          tests = sequential $ aroundAll withTestDBAndPort $ do
          describe "UpdateList API" $ do
          it "setup DB triggers and users" $ \((testEnv, _), _) -> do
          it "setup DB triggers and users" $ \(SpecContext testEnv _port _app _) -> do
          setupEnvironment testEnv
          createAliceAndBob testEnv
          describe "POST /api/v1.0/lists/:id/add/form/async (JSON)" $ do
          it "allows uploading a JSON ngrams file" $ \((testEnv, port), app) -> do
          it "allows uploading a JSON ngrams file" $ \(SpecContext testEnv port app _) -> do
          cId <- newCorpusForUser testEnv "alice"
          withApplication app $ do
          withValidLogin port "alice" (GargPassword "alice") $ \_clientEnv token -> do
          ......@@ -142,7 +145,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          ]
          } |]
          it "does not create duplicates when uploading JSON (#313)" $ \((testEnv, port), app) -> do
          it "does not create duplicates when uploading JSON (#313)" $ \(SpecContext testEnv port app _) -> do
          cId <- newCorpusForUser testEnv "alice"
          withApplication app $ do
          withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
          ......@@ -206,7 +209,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          describe "POST /api/v1.0/lists/:id/csv/add/form/async (CSV)" $ do
          it "parses CSV via ngramsListFromCSVData" $ \((_testEnv, _port), _app) -> do
          it "parses CSV via ngramsListFromCSVData" $ \(SpecContext _testEnv _port _app _) -> do
          simpleNgrams <- liftIO (TIO.readFile =<< getDataFileName "test-data/ngrams/simple.tsv")
          ngramsListFromTSVData simpleNgrams `shouldBe`
          Right (Map.fromList [ (NgramsTerms, Versioned 0 $ Map.fromList [
          ......@@ -214,7 +217,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          , (NgramsTerm "brazorf", NgramsRepoElement 1 StopTerm Nothing Nothing (MSet mempty))
          ])])
          it "allows uploading a CSV ngrams file" $ \((testEnv, port), app) -> do
          it "allows uploading a CSV ngrams file" $ \(SpecContext testEnv port app _) -> do
          cId <- newCorpusForUser testEnv "alice"
          withApplication app $ do
          withValidLogin port "alice" (GargPassword "alice") $ \_clientEnv token -> do
          ......@@ -257,12 +260,12 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          describe "POST /api/v1.0/corpus/:id/add/form/async (JSON)" $ do
          it "allows uploading a JSON docs file" $ \((testEnv, port), app) ->
          it "allows uploading a JSON docs file" $ \(SpecContext testEnv port app _) ->
          withApplication app $ do
          withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
          void $ createFortranDocsList testEnv port clientEnv token
          it "doesn't use trashed documents for score calculation (#385)" $ \((testEnv, port), app) -> do
          it "doesn't use trashed documents for score calculation (#385)" $ \(SpecContext testEnv port app _) -> do
          withApplication app $ do
          withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
          corpusId <- createFortranDocsList testEnv port clientEnv token
          ......@@ -336,21 +339,28 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
          ) clientEnv
          length (_ne_occurrences fortran_ngram') `shouldBe` 1
          createFortranDocsList :: TestEnv -> Int -> ClientEnv -> Token -> WaiSession () CorpusId
          createFortranDocsList testEnv port clientEnv token = do
          createDocsList :: FilePath
          -> TestEnv
          -> Int
          -> ClientEnv
          -> Token
          -> WaiSession () CorpusId
          createDocsList testDataPath testEnv port clientEnv token = do
          folderId <- liftIO $ newPrivateFolderForUser testEnv "alice"
          ([corpusId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build folderId)) [aesonQQ|{"pn_typename":"NodeCorpus","pn_name":"TestCorpus"}|]
          -- Import the docsList with only two documents, both containing a \"fortran\" term.
          simpleDocs <- liftIO (TIO.readFile =<< getDataFileName "test-data/ngrams/GarganText_DocsList-nodeId-177.json")
          let newWithForm = mkNewWithForm simpleDocs "GarganText_DocsList-nodeId-177.json"
          simpleDocs <- liftIO (TIO.readFile =<< getDataFileName testDataPath)
          let newWithForm = mkNewWithForm simpleDocs (T.pack $ takeBaseName testDataPath)
          (j :: JobPollHandle) <- checkEither $ fmap toJobPollHandle <$> liftIO (runClientM (add_file_async token corpusId newWithForm) clientEnv)
          let mkPollUrl jh = "/corpus/" <> fromString (show $ _NodeId corpusId) <> "/add/form/async/" +|_jph_id jh|+ "/poll?limit=1"
          j' <- pollUntilFinished token port mkPollUrl j
          liftIO (_jph_status j' `shouldBe` "IsFinished")
          pure corpusId
          createFortranDocsList :: TestEnv -> Int -> ClientEnv -> Token -> WaiSession () CorpusId
          createFortranDocsList testEnv port =
          createDocsList "test-data/ngrams/GarganText_DocsList-nodeId-177.json" testEnv port
          updateNode :: Int -> ClientEnv -> Token -> NodeId -> WaiSession () ()
          updateNode port clientEnv token nodeId = do
          let params = UpdateNodeParamsTexts Both
          ......
          test/Test/Core/AsyncUpdates.hs
          View file @ fff00f20
          ......@@ -9,7 +9,7 @@ Portability : POSIX
          -}
          module Test.Core.Notifications
          module Test.Core.AsyncUpdates
          ( test
          , qcTests )
          where
          ......
          test/Test/Database/Operations/DocumentSearch.hs
          View file @ fff00f20
          ......@@ -135,6 +135,8 @@ stemmingTest :: TestEnv -> Assertion
          stemmingTest _env = do
          stem EN GargPorterAlgorithm "Ajeje" `shouldBe` "Ajeje"
          stem EN GargPorterAlgorithm "PyPlasm:" `shouldBe` "PyPlasm:"
          stem EN GargPorterAlgorithm "soy" `shouldBe` "soy"
          stem EN GargPorterAlgorithm "cry" `shouldBe` "cri"
          -- This test outlines the main differences between Porter and Lancaster.
          stem EN GargPorterAlgorithm "dancer" `shouldBe` "dancer"
          stem EN LancasterAlgorithm "dancer" `shouldBe` "dant"
          ......
          test/Test/Ngrams/Lang/Occurrences.hs
          View file @ fff00f20
          ......@@ -14,7 +14,28 @@ commentary with @some markup@.
          {-# LANGUAGE ScopedTypeVariables #-}
          module Test.Ngrams.Lang.Occurrences where
          import Test.Hspec
          import Data.Either
          import Gargantext.Core.Text.Terms.WithList
          import Gargantext.Core (Lang(ZH, EN))
          import Gargantext.Prelude
          test :: Spec
          test = do
          describe "terms in text counting" $ do
          it "words with quotes should match" $ do
          let ngrams = ["j'aime"]
          let doc = "j'aime"
          let output = []
          termsInText EN (buildPatternsWith EN ngrams) doc `shouldBe` [("j'aime", 1)]
          -- it "words with quotes should match and be case sentive" $ do
          -- let ngrams = ["j'aIme"]
          -- let doc = "j'aime"
          -- let output = []
          -- termsInText EN (buildPatternsWith EN ngrams) doc `shouldNotBe` [("j'aime", 1)]
          {-
          import Test.Hspec
          ......
          test/Test/Offline/Phylo.hs
          View file @ fff00f20
          {-# LANGUAGE TypeApplications #-}
          {-# LANGUAGE ScopedTypeVariables #-}
          {-# LANGUAGE QuasiQuotes #-}
          {-# LANGUAGE TupleSections #-}
          module Test.Offline.Phylo (tests) where
          import CLI.Phylo.Common
          import Data.Aeson as JSON
          import Data.Aeson.Types qualified as JSON
          import Data.Aeson.Encode.Pretty qualified as JSON
          import Data.ByteString.Lazy qualified as BL
          import Data.GraphViz.Attributes.Complete qualified as Graphviz
          import Data.Text.Lazy as TL
          import Data.TreeDiff
          import Data.Vector qualified as V
          import Gargantext.Core.Text.List.Formats.TSV
          import Gargantext.Core.Types.Phylo hiding (Phylo(..))
          import Gargantext.Core.Viz.Phylo hiding (EdgeType(..))
          import Gargantext.Core.Viz.Phylo.API.Tools (readPhylo, phylo2dot2json)
          import Gargantext.Core.Viz.Phylo.Example qualified as Cleopatre
          import Gargantext.Core.Viz.Phylo hiding (EdgeType(..))
          import Gargantext.Core.Viz.Phylo.PhyloExport
          import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo, toPhyloWithoutLink)
          import Gargantext.Core.Viz.Phylo.PhyloTools
          import Paths_gargantext
          import Prelude
          import Test.Tasty
          import Test.Tasty.Golden (goldenVsStringDiff)
          import Test.Tasty.HUnit
          import qualified Test.Tasty.Golden.Advanced as Advanced
          phyloTestConfig :: PhyloConfig
          phyloTestConfig = PhyloConfig {
          ......@@ -48,6 +53,32 @@ phyloTestConfig = PhyloConfig {
          , exportFilter = [ByBranchSize {_branch_size = 3.0}]
          }
          phyloGolden :: TestName -> (FilePath, IO BL.ByteString) -> TestTree
          phyloGolden testName (fp, action) =
          goldenVsStringDiff testName differ fp action
          where
          differ ref new = [ "diff", "-u", "-w", "--color=always", ref, new]
          -- | Use this variant for those tests which requires a more sophisticated way of
          -- comparing outputs directly on the GraphData
          phyloGoldenGraphData :: TestName -> (FilePath, IO GraphData) -> TestTree
          phyloGoldenGraphData testName (goldenPath, getActual) =
          Advanced.goldenTest testName getGolden getActual differ updateGolden
          where
          differ ref new = pure $ case compareGraphDataFuzzy ref new of
          True -> Nothing
          False -> Just $ show (ansiWlEditExprCompact $ ediff ref new)
          updateGolden :: GraphData -> IO ()
          updateGolden gd = BL.writeFile goldenPath (JSON.encodePretty gd)
          getGolden :: IO GraphData
          getGolden = do
          expected_e <- JSON.eitherDecodeFileStrict' =<< getDataFileName goldenPath
          case expected_e of
          Left err -> fail err
          Right (expected :: GraphData) -> pure expected
          tests :: TestTree
          tests = testGroup "Phylo" [
          testGroup "Export" [
          ......@@ -56,14 +87,14 @@ tests = testGroup "Phylo" [
          ]
          , testGroup "toPhyloWithoutLink" [
          testCase "returns expected data" testSmallPhyloWithoutLinkExpectedOutput
          , testCase "phyloCleopatre returns expected data" testCleopatreWithoutLinkExpectedOutput
          , testCase "Nadal canned corpus returns expected data" testNadalWithoutLinkExpectedOutput
          , phyloGolden "phyloCleopatre returns expected data" testCleopatreWithoutLinkExpectedOutput
          , phyloGolden "Nadal canned corpus returns expected data" testNadalWithoutLinkExpectedOutput
          ]
          , testGroup "phylo2dot2json" [
          testCase "is deterministic" testPhylo2dot2json
          phyloGoldenGraphData "is deterministic" testPhylo2dot2json
          ]
          , testGroup "toPhylo" [
          testCase "is deterministic" testToPhyloDeterminism
          phyloGolden "is deterministic" testToPhyloDeterminism
          ]
          , testGroup "relatedComponents" [
          testCase "finds simple connection" testRelComp_Connected
          ......@@ -71,14 +102,13 @@ tests = testGroup "Phylo" [
          , testCase "parses csv phylo" testCsvPhylo
          ]
          testCleopatreWithoutLinkExpectedOutput :: Assertion
          testCleopatreWithoutLinkExpectedOutput = do
          testCleopatreWithoutLinkExpectedOutput :: (FilePath, IO BL.ByteString)
          testCleopatreWithoutLinkExpectedOutput =
          let actual = toPhyloWithoutLink Cleopatre.docs Cleopatre.config
          expected <- readPhylo =<< getDataFileName "test-data/phylo/cleopatre.golden.json"
          assertBool (show $ ansiWlEditExprCompact $ ediff expected actual) (expected == actual)
          in ("test-data/phylo/cleopatre.golden.json", pure $ JSON.encodePretty actual)
          testNadalWithoutLinkExpectedOutput :: Assertion
          testNadalWithoutLinkExpectedOutput = do
          testNadalWithoutLinkExpectedOutput :: (FilePath, IO BL.ByteString)
          testNadalWithoutLinkExpectedOutput = ("test-data/phylo/nadal.golden.json",) $ do
          corpusPath' <- getDataFileName "test-data/phylo/nadal_docslist.golden.tsv"
          listPath' <- getDataFileName "test-data/phylo/nadal_ngramslist.golden.tsv"
          let config = phyloTestConfig { corpusPath = corpusPath'
          ......@@ -90,9 +120,7 @@ testNadalWithoutLinkExpectedOutput = do
          (corpusPath config)
          [Year 3 1 5,Month 3 1 5,Week 4 2 5]
          mapList
          let actual = setConfig phyloTestConfig $ toPhyloWithoutLink corpus config
          expected <- setConfig phyloTestConfig <$> (readPhylo =<< getDataFileName "test-data/phylo/nadal.golden.json")
          assertBool (show $ ansiWlEditExprCompact $ ediff expected actual) (expected == actual)
          pure $ JSON.encodePretty $ setConfig phyloTestConfig $ toPhyloWithoutLink corpus config
          testSmallPhyloWithoutLinkExpectedOutput :: Assertion
          testSmallPhyloWithoutLinkExpectedOutput = do
          ......@@ -111,17 +139,12 @@ testSmallPhyloWithoutLinkExpectedOutput = do
          expected <- setConfig phyloTestConfig <$> (readPhylo =<< getDataFileName "test-data/phylo/small-phylo.golden.json")
          assertBool (show $ ansiWlEditExprCompact $ ediff expected actual) (expected == actual)
          testPhylo2dot2json :: Assertion
          testPhylo2dot2json = do
          expected_e <- JSON.eitherDecodeFileStrict' =<< getDataFileName "test-data/phylo/phylo2dot2json.golden.json"
          case expected_e of
          testPhylo2dot2json :: (FilePath, IO GraphData)
          testPhylo2dot2json = ("test-data/phylo/phylo2dot2json.golden.json",) $ do
          actual_e <- JSON.parseEither JSON.parseJSON <$> phylo2dot2json Cleopatre.phyloCleopatre
          case actual_e of
          Left err -> fail err
          Right (expected :: GraphData) -> do
          actual_e <- JSON.parseEither JSON.parseJSON <$> phylo2dot2json Cleopatre.phyloCleopatre
          case actual_e of
          Left err -> fail err
          Right (actual :: GraphData) -> do
          assertBool ("Phylo mismatch!" <> show (ansiWlEditExprCompact $ ediff expected actual)) (expected `compareGraphDataFuzzy` actual)
          Right (actual :: GraphData) -> pure actual
          compareGraphDataFuzzy :: GraphData -> GraphData -> Bool
          compareGraphDataFuzzy gd1 gd2 =
          ......@@ -232,8 +255,8 @@ testRelComp_Connected = do
          (relatedComponents @Int) [[1,2], [3,5], [2,4],[9,5],[5,4]] @?= [[1,2,4,3,5,9]]
          (relatedComponents @Int) [[1,2,5], [4,5,9]] @?= [[1,2,5,4,9]]
          testToPhyloDeterminism :: Assertion
          testToPhyloDeterminism = do
          testToPhyloDeterminism :: (FilePath, IO BL.ByteString)
          testToPhyloDeterminism = ("test-data/phylo/187481.json",) $ do
          corpusPath' <- getDataFileName "test-data/phylo/GarganText_DocsList-nodeId-187481.tsv"
          listPath' <- getDataFileName "test-data/phylo/GarganText_NgramsList-187482.tsv"
          let config = phyloTestConfig { corpusPath = corpusPath'
          ......@@ -246,8 +269,7 @@ testToPhyloDeterminism = do
          [Year 3 1 5,Month 3 1 5,Week 4 2 5]
          mapList
          let actual = setConfig phyloTestConfig $ toPhylo $ toPhyloWithoutLink corpus config
          expected <- setConfig phyloTestConfig <$> (readPhylo =<< getDataFileName "test-data/phylo/187481.json")
          assertBool ("Phylo mismatch! " <> show (ansiWlEditExprCompact $ ediff expected actual)) (expected == actual)
          pure $ JSON.encodePretty actual
          testCsvPhylo :: Assertion
          testCsvPhylo = do
          ......
          test/drivers/tasty/Main.hs
          View file @ fff00f20
          ......@@ -27,6 +27,8 @@ import qualified Test.Utils.Crypto as Crypto
          import qualified Test.Utils.Jobs as Jobs
          import qualified Test.Core.Similarity as Similarity
          import qualified Test.Core.Notifications as Notifications
          import qualified Test.Core.AsyncUpdates as AsyncUpdates
          import qualified Test.Ngrams.Lang.Occurrences as Occurrences
          import Test.Tasty
          import Test.Tasty.Hspec
          ......@@ -40,7 +42,8 @@ main = do
          nlpSpec <- testSpec "NLP" NLP.test
          jobsSpec <- testSpec "Jobs" Jobs.test
          similaritySpec <- testSpec "Similarity" Similarity.test
          asyncUpdatesSpec <- testSpec "Notifications" Notifications.test
          asyncUpdatesSpec <- testSpec "AsyncUpdates" AsyncUpdates.test
          occurrencesSepc <- testSpec "Occurrences" Occurrences.test
          defaultMain $ testGroup "Gargantext"
          [ utilSpec
          ......@@ -49,6 +52,7 @@ main = do
          , cryptoSpec
          , nlpSpec
          , jobsSpec
          , occurrencesSepc
          , NgramsQuery.tests
          , CorpusQuery.tests
          , TSVParser.tests
          ......
          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