Merge branch 'dev' into dev-phylo

.gitlab-ci.yml

-# This file is a template, and might need editing before it works on your project.
-# see https://docs.gitlab.com/ce/ci/yaml/README.html for all available options
-
-# you can delete this line if you're not using Docker
-#image: busybox:latest
-
-before_script:
-  - echo "Before script section"
-  - echo "For example you might run an update here or install a build dependency"
-  - echo "Or perhaps you might print out some debugging details"
-   
-after_script:
-  - echo "After script section"
-  - echo "For example you might do some cleanup here"
-   
-build1:
+# Thanks to:
+# https://vadosware.io/post/zero-to-continuous-integrated-testing-a-haskell-project-with-gitlab/
+#
+#
+image: haskell:8
+
+variables:
+  STACK_ROOT: "${CI_PROJECT_DIR}/.stack"
+  STACK_OPTS: "--system-ghc"
+
+cache:
+  paths:
+    - .stack
+    - .stack-work
+    - target
+
+#before_script:
+  #- apt-get update
+  #- apt-get install make xz-utils
+
+stages:
+  - build
+  - test
+
+build:
   stage: build
   script:
-    - ./install
-   
-#test1:
+    - make setup
+    - make build
+
+      # TOOO
+#unit-test:
 #  stage: test
-#  script: 
-#    - echo "Do a test here"
-#    - echo "For example run a test suite"
-#   
-#test2:
+#  script:
+#    - make test-unit
+#
+#int-test:
 #  stage: test
-#  script: 
-#    - echo "Do another parallel test here"
-#    - echo "For example run a lint test"
-#   
-#deploy1:
-#  stage: deploy
 #  script:
-#    - echo "Do your deploy here"
+#    - make test-int
+#
+#e2e-test:
+#  stage: test
+#  script:
+#    - make test-e2e
+#
+
+# If you find yourself with a non-sensical build error when you know your project should be building just fine, this fragment should help:
+#
+#build:
+#  stage: build
+#  script:
+#    # Clear out cache files
+#    - rm -rf .stack
+#    - rm -rf .stack-work
+#    - stack setup --system-ghc
+#    - stack install --local-bin-path target --system-ghc
+
+
+
+

README.md

@@ -18,38 +18,83 @@ progress. Please report and improve this documentation if you encounter
 issues.
 
 ### Build Core Code
+
 #### Docker
-  curl -sSL https://gitlab.iscpif.fr/gargantext/haskell-gargantext/raw/master/devops/docker-install | sh
+
+``` sh
+curl -sSL https://gitlab.iscpif.fr/gargantext/haskell-gargantext/raw/master/devops/docker/docker-install | sh
+```
 
 #### Debian
-  curl -sSL https://gitlab.iscpif.fr/gargantext/haskell-gargantext/raw/master/devops/debian-install | sh
+
+``` sh
+curl -sSL https://gitlab.iscpif.fr/gargantext/haskell-gargantext/raw/master/devops/debian/install | sh
+```
 
 ### Add dependencies
 
 1. CoreNLP is needed (EN and FR); This dependency will not be needed
    soon.
-  - wget https://dl.gargantext.org/coreNLP.tar.bz2
-  - tar xvjf coreNLP.tar.bz2
-  - ./startServer.sh
+
+``` sh
+./devops/install-corenlp
+```
 
 2. Louvain C++ needed to draw the socio-semantic graphs
-  - git clone https://gitlab.iscpif.fr/gargantext/clustering-louvain-cplusplus.git
-  - cd clustering-louvain-cplusplus
-  - ./install
+
+NOTE: This is already added in the Docker build.
+
+``` sh
+git clone https://gitlab.iscpif.fr/gargantext/clustering-louvain-cplusplus.git
+cd clustering-louvain-cplusplus
+./install
+```
 
 ### Initialization
 
-Users has to be created first (user1 is created as instance):
+#### Docker
+
+Run PostgreSQL first:
+
+``` sh
+cd devops/docker
+docker-compose up
+```
 
-- stack install
-- ~/.local/bin/gargantext-init "gargantext.ini"
+Initialization schema should be loaded automatically (from `devops/postgres/schema.sql`).
+
+#### Gargantext
+
+Users have to be created first (`user1` is created as instance):
+
+``` sh
+stack install
+~/.local/bin/gargantext-init "gargantext.ini"
+```
+
+For Docker env, run:
+
+``` sh
+stack --docker run gargantext-init -- gargantext.ini
+```
+
+### Importing data
+
+You can import some data with:
+``` sh
+docker run --rm -it -p 9000:9000 cgenie/corenlp-garg
+stack exec gargantext-import -- "corpusCsvHal" "user1" "IMT3" gargantext.ini 10000 ./1000.csv
+```
 
 ## Use Cases
 
 ### Multi-User with Graphical User Interface (Server Mode)
 
+``` sh
 ~/.local/bin/stack --docker exec gargantext-server -- --ini "gargantext.ini" --run Prod
-Then you can log in with user1:1resu
+```
+
+Then you can log in with `user1:1resu`.
 
 
 ### Command Line Mode tools

bin/gargantext-import/Main.hs

@@ -23,14 +23,14 @@ import Data.Either
 import Prelude (read)
 import Control.Exception (finally)
 import Gargantext.Prelude
-import Gargantext.Database.Flow (FlowCmdM, flowCorpusFile)
+import Gargantext.Database.Flow (FlowCmdM, flowCorpusFile, flowAnnuaire)
 import Gargantext.Text.Corpus.Parsers (FileFormat(..))
 import Gargantext.Database.Utils (Cmd, )
 import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument)
 import Gargantext.Database.Schema.User (insertUsersDemo)
 import Gargantext.Text.Terms (TermType(..))
 import Gargantext.Core (Lang(..))
-import Gargantext.API -- (GargError)
+import Gargantext.API.Types (GargError)
 import Gargantext.API.Node () -- instances
 import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
 import System.Environment (getArgs)
@@ -41,18 +41,27 @@ import Control.Monad.IO.Class (liftIO)
 
 main :: IO ()
 main = do
-  [userCreate, user, name, iniPath, limit, corpusPath] <- getArgs
+  [fun, user, name, iniPath, limit, corpusPath] <- getArgs
 
   --{-
+
   let createUsers :: Cmd GargError Int64
       createUsers = insertUsersDemo
   
   let
     --tt = (Unsupervised EN 6 0 Nothing)
     tt = (Multi EN)
-    format = CsvGargV3 -- CsvHalFormat --WOS
-    cmd :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
-    cmd = flowCorpusFile (cs user) (Left (cs name :: Text)) (read limit :: Int) tt  format corpusPath
+    format = CsvGargV3 -- CsvHal --WOS
+    corpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
+    corpus = flowCorpusFile (cs user) (Left (cs name :: Text)) (read limit :: Int) tt  format corpusPath
+
+    corpusCsvHal :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
+    corpusCsvHal = flowCorpusFile (cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHal corpusPath
+
+    annuaire :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
+    annuaire = flowAnnuaire (cs user) (Left "Annuaire") (Multi EN) corpusPath
+
+
   {-
   let debatCorpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
       debatCorpus = do
@@ -64,13 +73,23 @@ main = do
         flowCorpus (Text.pack user) (Text.pack name) (Multi FR) (map (map toHyperdataDocument) docs)
   --}
 
-
   withDevEnv iniPath $ \env -> do
-    _ <- if userCreate == "true"
+    _ <- if fun == "users"
           then runCmdDev env createUsers
           else pure 0 --(cs "false")
 
-    _ <- runCmdDev env cmd
+    _ <- if fun == "corpus"
+          then runCmdDev env corpus
+          else pure 0 --(cs "false")
+
+    _ <- if fun == "corpusCsvHal"
+          then runCmdDev env corpusCsvHal
+          else pure 0 --(cs "false")
+ 
+
+    _ <- if fun == "annuaire"
+            then runCmdDev env annuaire
+            else pure 0
     {-
     _ <- if corpusType == "csv"
             then runCmdDev env csvCorpus

bin/gargantext-init/Main.hs

@@ -19,36 +19,43 @@ Import a corpus binary.
 
 module Main where
 
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..))
 import System.Environment (getArgs)
 import Gargantext.Prelude
-import Gargantext.Database.Flow (FlowCmdM, flowCorpusFile, getOrMkRoot)
-import Gargantext.Text.Corpus.Parsers (FileFormat(..))
+import Gargantext.Database.Flow (getOrMkRoot, getOrMk_RootWithCorpus)
+import Gargantext.Database.Schema.Node (getOrMkList)
 import Gargantext.Database.Utils (Cmd, )
-import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument, RootId)
+import Gargantext.Database.Types.Node (CorpusId, RootId, HyperdataCorpus, ListId)
 import Gargantext.Database.Schema.User (insertUsersDemo, UserId)
-import Gargantext.Text.Terms (TermType(..))
-import Gargantext.Core (Lang(..))
-import Gargantext.API -- (GargError)
+import Gargantext.API.Types (GargError)
 import Gargantext.API.Node () -- instances
-import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
---import Gargantext.Text.Corpus.Parsers.GrandDebat (readFile, GrandDebatReference(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Control.Monad.IO.Class (liftIO)
-
+import Gargantext.API.Settings (withDevEnv, runCmdDev)
+import Gargantext.Database.Config (userMaster, corpusMasterName)
+import Gargantext.Database.Init (initTriggers)
 main :: IO ()
 main = do
   [iniPath] <- getArgs
 
   let createUsers :: Cmd GargError Int64
       createUsers = insertUsersDemo
-  
+
   let
-    mkRoots :: Cmd GargError (UserId, RootId)
-    mkRoots = getOrMkRoot "user1"
+    mkRoots :: Cmd GargError [(UserId, RootId)]
+    mkRoots = mapM getOrMkRoot ["gargantua", "user1", "user2"]
+    -- TODO create all users roots
 
+  let
+    initMaster :: Cmd GargError (UserId, RootId, CorpusId, ListId)
+    initMaster = do
+      (masterUserId, masterRootId, masterCorpusId) <- getOrMk_RootWithCorpus userMaster (Left corpusMasterName) (Nothing :: Maybe HyperdataCorpus)
+      masterListId <- getOrMkList masterCorpusId masterUserId
+      _triggers <- initTriggers masterListId
+      pure (masterUserId, masterRootId, masterCorpusId, masterListId)
 
   withDevEnv iniPath $ \env -> do
     _ <- runCmdDev env createUsers
     _ <- runCmdDev env mkRoots
+    x <- runCmdDev env initMaster
+    putStrLn $ show x
     pure ()

build-shell.nix

+{ghc}:
+with (import <nixpkgs> {});
+
+haskell.lib.buildStackProject {
+  inherit ghc;
+  name = "gargantext";
+  buildInputs = [
+    docker-compose
+    blas
+    bzip2
+    #gfortran
+    gfortran.cc.lib
+    glibc
+    gmp
+    gsl
+    igraph
+    liblapack
+    pcre
+    postgresql
+    #stack
+    xz
+    zlib
+  ];
+}

coreNLP/Dockerfile

+FROM openjdk
+
+ADD home/debian/CoreNLP /CoreNLP
+WORKDIR /CoreNLP
+
+CMD ./startServer.sh

default.nix

+with (import <nixpkgs> {});
+stdenv.mkDerivation rec {
+  name = "env";
+  env = buildEnv {
+    name = name;
+    paths = buildInputs;
+  };
+  buildInputs = [
+    docker-compose
+    #glibc
+    #gmp
+    #gsl
+    #igraph
+    #pcre
+    #postgresql
+    #stack
+    #xz
+  ];
+  builder = builtins.toFile "builder.sh" ''
+    source $stdenv/setup
+    touch $out
+  '';
+}

devops/debian/debian-install

-#!/bin/bash
-
-
-
-if git --version;
-then 
-  echo "git installed, ok"
-else
-  sudo apt update && sudo apt install git
-fi
-
-sudo apt update
-sudo apt install liblzma-dev libpcre3-dev libblas-dev liblapack-dev pkg-config libgsl-dev libbz2-dev postgresql postgresql-server-dev-9.6 nginx libigraph-dev
-
-#echo "Which user?"
-#read USER
-#sudo adduser --disabled-password --gecos "" $USER
-#sudo su $USER
-
-curl -sSL https://get.haskellstack.org/ | sh
-stack update
-stack upgrade
-
-
-git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
-
-cd haskell-gargantext
-git clone https://gitlab.iscpif.fr/gargantext/purescript-gargantext
-
-mkdir deps
-cd deps
-git clone https://gitlab.iscpif.fr/gargantext/clustering-louvain.git
-git clone https://github.com/np/servant-job.git
-git clone https://github.com/np/patches-map
-git clone https://gitlab.com/npouillard/patches-class.git
-git clone https://github.com/delanoe/haskell-opaleye
-git clone -b next --single-branch https://github.com/delanoe/hsparql
-cd ..
-
-stack setup
-stack build
-stack install
-
-
-# Specific to our servers
-
-### Configure timezone and locale ###################################
-echo "###########  LOCALES & TZ #################"
-echo "Europe/Paris" > /etc/timezone
-dpkg-reconfigure --frontend=noninteractive tzdata
-#ENV TZ "Europe/Paris"
-
-sed -i -e 's/# en_GB.UTF-8 UTF-8/en_GB.UTF-8 UTF-8/' /etc/locale.gen && \
-sed -i -e 's/# fr_FR.UTF-8 UTF-8/fr_FR.UTF-8 UTF-8/' /etc/locale.gen && \
-locale-gen && \
-update-locale LANG=fr_FR.UTF-8 && \
-update-locale LANGUAGE=fr_FR.UTF-8 && \
-update-locale LC_ALL=fr_FR.UTF-8
-################################################################
-
-# Database configuration
-# CREATE USER gargantua WITH PASSWORD $(grep DB_PASS gargantext.ini)
-# GRANT ALL PRIVILEGES ON DATABASE gargandbV4 to gargantua
-
-#######################################################################
-## POSTGRESQL DATA (as ROOT)
-#######################################################################
-sed -iP "s%^data_directory.*%data_directory = \'\/srv\/gargandata\'%" /etc/postgresql/9.6/main/postgresql.conf 
-echo "host all  all    0.0.0.0/0  md5" >> /etc/postgresql/9.6/main/pg_hba.conf                                 
-echo "listen_addresses='*'" >> /etc/postgresql/9.6/main/postgresql.conf
-

devops/debian/debianPkgs

@@ -14,5 +14,5 @@ sudo apt install liblzma-dev libpcre3-dev libblas-dev liblapack-dev pkg-config l
 # Phylo management
 sudo apt install graphviz
 
-sudo apt install postgresql-server-dev-9.6 
+sudo apt install postgresql-server-dev-11
 

devops/debian/deps

+#!/bin/bash
+
+git clone https://gitlab.iscpif.fr/gargantext/clustering-louvain-cplusplus.git
+cd clustering-louvain-cplusplus
+./install
+cd ..
+
+
+sudo apt install default-jdk
+wget https://dl.gargantext.org/coreNLP.tar.bz2
+tar xvjf coreNLP.tar.bz2
+# ./startServer.sh
+
+

devops/docker/Dockerfile

-from fpco/stack-build:lts-12.26
+from fpco/stack-build:lts-14.6
 
 RUN apt-get update && \
     apt-get install -y git libigraph0-dev && \

devops/docker/docker-compose.yaml

@@ -10,9 +10,15 @@ services:
       POSTGRES_PASSWORD: C8kdcUrAQy66U
       POSTGRES_DB: gargandbV5
     volumes:
-      - pgdata:/var/lib/postgresql/data
+      - garg-pgdata:/var/lib/postgresql/data
       - ../:/gargantext
       - ../dbs:/dbs
+      - ../postgres/schema.sql:/docker-entrypoint-initdb.d/schema.sql:ro
+
+  corenlp:
+    image: 'cgenie/corenlp-garg'
+    ports:
+      - 9000:9000
 
 volumes:
-  pgdata:
+  garg-pgdata:

devops/docker/docker-import

+#!/bin/bash
+
 if [ "$#" -lt 3 ]; then
   echo "Usage: $0 <name> <path> <limit>"
   exit 1

devops/docker/docker-install

@@ -37,27 +37,27 @@ exec sudo -E /usr/bin/docker \"\$@\"" >> $DOCKERBIN
 fi
 ########################################################################
 
-curl -sSL https://get.haskellstack.org/ | sh
-stack update
-stack upgrade
-
+if stack --version;
+then
+  echo "Haskell stack installed, ok"
+else
+  curl -sSL https://get.haskellstack.org/ | sh
+  stack update
+  stack upgrade
+fi
 
 git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
 
 cd haskell-gargantext
 git clone https://gitlab.iscpif.fr/gargantext/purescript-gargantext
 
-mkdir deps
-cd deps
-git clone https://gitlab.iscpif.fr/gargantext/clustering-louvain.git
-git clone https://github.com/np/servant-job.git
-git clone https://github.com/np/patches-map
-git clone https://gitlab.com/npouillard/patches-class.git
-git clone https://github.com/delanoe/haskell-opaleye
-git clone -b next --single-branch https://github.com/delanoe/hsparql
-cd ..
+../install-deps $(pwd)
+
+pushd devops/docker
+docker build --pull -t fpco/stack-build:lts-14.22-garg .
+popd
 
-stack docker pull
+#stack docker pull
 stack --docker setup
 stack --docker build
 stack --docker install

devops/docker/docker-postgres

+#!/bin/bash
+
 set -eu
+
 docker stop dbgarg || :
 docker rm --volumes dbgarg || :
 export PGPASSWORD="$(grep DB_PASS gargantext.ini | \awk '{print $3}')"
 docker run --name dbgarg -e POSTGRES_USER=gargantua -e POSTGRES_DB=gargandbV5 -e POSTGRES_PASSWORD=${PGPASSWORD} -d postgres
 sleep 3
-docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres  -U gargantua -d gargandbV5 < src/Gargantext/Database/Schema/schema.sql
+docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres  -U gargantua -d gargandbV5 < devops/postgres/schema.sql
 #docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres psql -h postgres  -U gargantua  -d gargandbV5 < gargantext.dump
 #docker run -e PGPASSWORD -i --rm --link dbgarg:postgres postgres dropdb -h postgres  -U gargantua gargandbV5

devops/docker/docker-prod

+#!/bin/bash
+
 stack --docker exec gargantext-server -- --run Prod --ini gargantext.ini

devops/install-corenlp

+#!/bin/bash
+
+if [ ! -d coreNLP ]; then
+    mkdir -v coreNLP
+fi
+
+pushd coreNLP
+
+wget https://dl.gargantext.org/coreNLP.tar.bz2
+tar xvjf coreNLP.tar.bz2
+pushd home/debian/CoreNLP
+./startServer.sh

devops/install-deps

+#!/bin/bash
+
+DIR=$1
+DEPS_DIR=${DIR}/deps
+
+function clone_or_update() {
+    REPO=$1
+    echo "Checking repo ${REPO}"
+    # strip only dir name from URL
+    DIR=${REPO##*/}
+    # strip the remaining '.git' suffix
+    RAW_DIR=${DIR%.*}
+    if [ -d "${RAW_DIR}" ]; then
+        pushd ${RAW_DIR}
+        git pull
+        popd ..
+    else
+        git clone "$@"
+    fi
+}
+
+if [ ! -d "${DEPS_DIR}" ]; then
+    mkdir ${DIR}/deps
+fi
+
+cd ${DIR}/deps
+
+clone_or_update https://gitlab.iscpif.fr/gargantext/clustering-louvain.git
+clone_or_update https://github.com/np/servant-job.git
+clone_or_update https://github.com/np/patches-map
+clone_or_update https://gitlab.com/npouillard/patches-class.git
+clone_or_update https://github.com/delanoe/haskell-opaleye
+clone_or_update https://github.com/delanoe/hsparql -b next --single-branch

devops/nginx/default

+
+##
+# You should look at the following URL's in order to grasp a solid understanding
+# of Nginx configuration files in order to fully unleash the power of Nginx.
+# http://wiki.nginx.org/Pitfalls
+# http://wiki.nginx.org/QuickStart
+# http://wiki.nginx.org/Configuration
+#
+# Generally, you will want to move this file somewhere, and start with a clean
+# file but keep this around for reference. Or just disable in sites-enabled.
+#
+# Please see /usr/share/doc/nginx-doc/examples/ for more detailed examples.
+##
+
+
+server {
+    if ($host = dev.gargantext.org) {
+        return 301 https://$host$request_uri;
+    } # managed by Certbot
+
+
+    listen 80;
+        
+    server_name dev.gargantext.org;
+
+    add_header Cache-Control "no-cache";
+
+    location '/.well-known/acme-challenge' {
+        root /var/www/gargantext;
+    }
+
+    # Always redirect to https
+    return 301 https://dev.gargantext.org$request_uri;
+
+
+}
+
+server {
+    listen 443;
+    listen [::]:443 ssl;
+
+    server_name dev.gargantext.org;
+    
+    # Some options configurations:    
+    # https://github.com/h5bp/server-configs-nginx/blob/master/h5bp/location/expires.conf 
+    add_header Cache-Control "no-cache";
+
+    # SSL configuration
+    #
+    # listen 443 ssl default_server;
+    # listen [::]:443 ssl default_server;
+    
+    ssl on;
+    ssl_certificate /etc/letsencrypt/live/dev.gargantext.org/fullchain.pem; # managed by Certbot
+    ssl_certificate_key /etc/letsencrypt/live/dev.gargantext.org/privkey.pem; # managed by Certbot 
+
+    # Note: You should disable gzip for SSL traffic.
+    # See: https://bugs.debian.org/773332
+    #
+    # Read up on ssl_ciphers to ensure a secure configuration.
+    # See: https://bugs.debian.org/765782
+    #
+    # Self signed certs generated by the ssl-cert package
+    # Don't use them in a production server!
+    #
+    # include snippets/snakeoil.conf;
+
+    client_max_body_size 800M;
+    client_body_timeout 12;
+    client_header_timeout 12;
+    keepalive_timeout 15;
+    send_timeout 10;
+
+    root /var/www/html;
+    index index.html;
+    
+    #add_header Access-Control-Allow-Origin $http_origin always; 
+    # Add index.php to the list if you are using PHP
+    #index index.html index.htm index.nginx-debian.html;
+    
+    # CORS config borrowed from: https://gist.github.com/pauloricardomg/7084524
+    # NP: not sure we need CORS yet
+    #
+    if ($http_origin ~* (^https?://(127.0.0.1|localhost|dev\.gargantext\.com))) {
+      set $cors "1";
+    }
+    #
+    # Cross-Origin Resource Sharing
+    if ($request_method = "OPTIONS") {
+      set $cors "${cors}o";
+    }
+
+
+     # SSL CERT renewal 
+     location '/.well-known/acme-challenge' {
+       alias /var/www/gargantext/.well-known/acme-challenge ;
+     }
+
+
+     location /api {
+#      limit_except OPTIONS {
+#        auth_basic           "Gargantext's Development Version";
+#        auth_basic_user_file /etc/nginx/haskell_gargantext.htpasswd; 
+#      }
+
+       proxy_set_header X-Real-IP         $remote_addr;
+       proxy_set_header X-Forwarded-For   $proxy_add_x_forwarded_for;
+       proxy_set_header X-Forwarded-Proto $scheme;
+       proxy_set_header Host              $http_host;
+       proxy_redirect   off;
+       proxy_pass       http://127.0.0.1:8008;
+
+
+     }
+
+     location / {
+       # https://stackoverflow.com/a/48708812
+       limit_except OPTIONS {
+         auth_basic           "Gargantext's Development Version";
+         auth_basic_user_file /etc/nginx/haskell_gargantext.htpasswd; 
+       }
+
+       proxy_set_header X-Real-IP         $remote_addr;
+       proxy_set_header X-Forwarded-For   $proxy_add_x_forwarded_for;
+       proxy_set_header X-Forwarded-Proto $scheme;
+       proxy_set_header Host              $http_host;
+       proxy_redirect   off;
+       proxy_pass       http://127.0.0.1:8008;
+
+
+     }
+
+     #access_log off;
+     access_log /var/log/nginx/access.log;
+     error_log /var/log/nginx/error.log;
+
+}
+

devops/nginx/install

+
+sudo apt install apache2-utils
+htpasswd -c /etc/nginx/haskell_gargantext.htpasswd username1
+
+sudo apt-get install certbot python-certbot-nginx
+sudo certbot --nginx

devops/postgres/create

 #!/bin/bash
 
-sudo su postgres
+# sudo su postgres
 
-PW="password"
+# postgresql://$USER:$PW@localhost/$DB
+
+PW="C8kdcUrAQy66U"
 DB="gargandbV5"
 USER="gargantua"
 
-psql -c "CREATE USER \"${USER}\"
-psql -c "ALTER USER \"${USER}\" with PASSWORD \"${PW}\""
+psql -c "CREATE USER \"${USER}\""
+psql -c "ALTER USER \"${USER}\" with PASSWORD '${PW}'"
 
 psql -c "DROP DATABASE IF EXISTS \"${DB}\""
 createdb "${DB}"
 psql "${DB}" < schema.sql
 
-psql -c "ALTER DATABASE \"${DB}\" OWNER to \"${USER}\" ;"
+psql -c "ALTER DATABASE \"${DB}\" OWNER to \"${USER}\""
 
 
 

package.yaml

 name: gargantext
-version: '4.0.0.6'
+version: '0.0.0.4'
 synopsis: Search, map, share
 description: Please see README.md
 category: Data
@@ -33,11 +33,14 @@ library:
     #  - Gargantext.API.Orchestrator
   - Gargantext.API.Search
   - Gargantext.API.Settings
+  - Gargantext.API.Types
   - Gargantext.Core
   - Gargantext.Core.Types
   - Gargantext.Core.Types.Main
   - Gargantext.Core.Utils.Prefix
   - Gargantext.Database
+  - Gargantext.Database.Init
+  - Gargantext.Database.Config
   - Gargantext.Database.Flow
   - Gargantext.Database.Schema.Node
   - Gargantext.Database.Tree
@@ -85,11 +88,13 @@ library:
   - aeson
   - aeson-lens
   - aeson-pretty
+  - argon2
   - async
   - attoparsec
   - auto-update
   - base >=4.7 && <5
   - base16-bytestring
+  - base64-bytestring
   - blaze-html
   - blaze-markup
   - blaze-svg
@@ -97,6 +102,7 @@ library:
   - case-insensitive
   - cassava
   #- charsetdetect-ae  # detect charset
+  - clock
   - clustering-louvain
   - conduit
   - conduit-extra
@@ -112,6 +118,7 @@ library:
   - duckling
   - exceptions
   - filepath
+  - formatting
   - fullstop
   - fclabels
   - fgl
@@ -133,7 +140,7 @@ library:
   - hlcm
   - ini
   - insert-ordered-containers
-  - jose-jwt
+  - jose
     #  - kmeans-vector
   - json-stream
   - KMP
@@ -159,10 +166,13 @@ library:
   - profunctors
   - protolude
   - pureMD5
+  - random-shuffle
+  - MonadRandom
   - SHA
   - simple-reflect
   - cereal     # (IGraph)
   - singletons # (IGraph)
+  - quickcheck-instances
   - random
   - rake
   - regex-compat
@@ -172,9 +182,12 @@ library:
   - semigroups
   - servant
   - servant-auth
+  - servant-auth-server >= 0.4.4.0
+  - servant-auth-swagger
   - servant-blaze
   - servant-client
-    #  - servant-job
+  - servant-flatten
+  - servant-job
   - servant-mock
   - servant-multipart
   - servant-server
@@ -196,6 +209,7 @@ library:
   - transformers
   - transformers-base
   - unordered-containers
+  - Unique
   - uuid
   - validity
   - vector

src/Gargantext/API/Annuaire.hs

+{-|
+Module      : Gargantext.API.Annuaire
+Description : New annuaire API
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# LANGUAGE NoImplicitPrelude  #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE TypeOperators      #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE RankNTypes         #-}
+
+module Gargantext.API.Annuaire
+      where
+
+import Control.Lens hiding (elements)
+import Data.Aeson
+import Data.Swagger
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import qualified Gargantext.API.Corpus.New.File as NewFile
+import Gargantext.API.Orchestrator.Types
+import Gargantext.Core (Lang(..))
+import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
+import Gargantext.Database.Flow (FlowCmdM)  -- flowAnnuaire
+import Gargantext.Database.Types.Node (AnnuaireId)
+import Gargantext.Prelude
+import Servant
+import Servant.API.Flatten (Flat)
+import Servant.Job.Core
+import Servant.Job.Types
+import Servant.Job.Utils (jsonOptions)
+import Web.FormUrlEncoded          (FromForm)
+
+
+type Api = Summary "New Annuaire endpoint"
+         :> Post '[JSON] AnnuaireId
+
+------------------------------------------------------------------------
+------------------------------------------------------------------------
+data WithForm = WithForm
+  { _wf_filetype :: !NewFile.FileType
+  , _wf_data     :: !Text
+  , _wf_lang     :: !(Maybe Lang)
+  } deriving (Eq, Show, Generic)
+
+makeLenses ''WithForm
+instance FromForm WithForm
+instance FromJSON WithForm where
+  parseJSON = genericParseJSON $ jsonOptions "_wf_"
+instance ToSchema WithForm where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wf_")
+
+------------------------------------------------------------------------
+type AsyncJobs event ctI input output =
+  Flat (AsyncJobsAPI' 'Unsafe 'Safe ctI '[JSON] Maybe event input output)
+------------------------------------------------------------------------
+
+type AddWithForm = Summary "Add with FormUrlEncoded to annuaire endpoint"
+   :> "annuaire"
+   :> Capture "annuaire_id" AnnuaireId
+   :> "add"
+   :> "form"
+   :> "async"
+   :> AsyncJobs ScraperStatus '[FormUrlEncoded] WithForm ScraperStatus
+
+------------------------------------------------------------------------
+addToAnnuaireWithForm :: FlowCmdM env err m
+                    => AnnuaireId
+                    -> WithForm
+                    -> (ScraperStatus -> m ())
+                    -> m ScraperStatus
+addToAnnuaireWithForm _cid (WithForm ft _d _l) logStatus = do
+
+  printDebug "ft" ft
+
+  -- let
+    -- parse = case ft of
+    --   CSV_HAL   -> Parser.parseFormat Parser.CsvHal
+    --   CSV       -> Parser.parseFormat Parser.CsvGargV3
+    --   WOS       -> Parser.parseFormat Parser.WOS
+    --   PresseRIS -> Parser.parseFormat Parser.RisPresse
+
+  -- docs <- liftIO
+  --       $ splitEvery 500
+  --      <$> take 1000000
+  --      <$> parse (cs d)
+
+  logStatus ScraperStatus { _scst_succeeded = Just 1
+                          , _scst_failed    = Just 0
+                          , _scst_remaining = Just 1
+                          , _scst_events    = Just []
+                          }
+  -- cid' <- flowCorpus "user1"
+  --                    (Right [cid])
+  --                    (Multi $ fromMaybe EN l)
+  --                    (map (map toHyperdataDocument) docs)
+
+  -- printDebug "cid'" cid'
+
+  pure      ScraperStatus { _scst_succeeded = Just 2
+                          , _scst_failed    = Just 0
+                          , _scst_remaining = Just 0
+                          , _scst_events    = Just []
+                          }
+

src/Gargantext/API/Auth.hs

@@ -7,7 +7,7 @@ Maintainer  : team@gargantext.org
 Stability   : experimental
 Portability : POSIX
 
-Main authorisation of Gargantext are managed in this module
+Main authorization of Gargantext are managed in this module
 
 -- 1: Implement the Server / Client JWT authentication
       -> Client towards Python Backend
@@ -16,27 +16,41 @@ Main authorisation of Gargantext are managed in this module
 -- 2: Implement the Auth API backend
     https://github.com/haskell-servant/servant-auth
 
+TODO-ACCESS Critical
+
 -}
 
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
 
 module Gargantext.API.Auth
       where
 
+import Control.Lens (view)
+import Control.Monad.IO.Class (liftIO)
 import Data.Aeson.TH (deriveJSON)
 import Data.List (elem)
 import Data.Swagger
 import Data.Text (Text, reverse)
+import Data.Text.Lazy (toStrict)
+import Data.Text.Lazy.Encoding (decodeUtf8)
 import GHC.Generics (Generic)
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Servant
+import Servant.Auth.Server
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.API.Settings
+import Gargantext.API.Types (HasJoseError(..), joseError, HasServerError, GargServerC)
+--import Gargantext.API.Types (HasJoseError(..), joseError, HasServerError, serverError, GargServerC)
 import Gargantext.Database.Root (getRoot)
-import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId)
-import Gargantext.Database.Utils (Cmd)
+import Gargantext.Database.Tree (isDescendantOf, isIn)
+import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId(..), UserId, ListId, DocId)
+import Gargantext.Database.Utils (Cmd', CmdM, HasConnection)
 import Gargantext.Prelude hiding (reverse)
 import Test.QuickCheck (elements, oneof)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
@@ -69,20 +83,34 @@ type TreeId = NodeId
 
 -- | Main functions of authorization
 
-
 -- | Main types of authorization
 data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId
   deriving (Eq)
 
-checkAuthRequest :: Username -> Password -> Cmd err CheckAuth
+makeTokenForUser :: (HasSettings env, HasJoseError err)
+                 => NodeId -> Cmd' env err Token
+makeTokenForUser uid = do
+  jwtS <- view $ settings . jwtSettings
+  e <- liftIO $ makeJWT (AuthenticatedUser uid) jwtS Nothing
+  -- TODO-SECURITY here we can implement token expiration ^^.
+  either joseError (pure . toStrict . decodeUtf8) e
+  -- TODO not sure about the encoding...
+
+checkAuthRequest :: (HasSettings env, HasConnection env, HasJoseError err)
+                 => Username -> Password -> Cmd' env err CheckAuth
 checkAuthRequest u p
   | not (u `elem` arbitraryUsername) = pure InvalidUser
   | u /= reverse p = pure InvalidPassword
   | otherwise = do
-      muId <- getRoot "user1"
-      pure $ maybe InvalidUser (Valid "token" . _node_id) $ head muId
-
-auth :: AuthRequest -> Cmd err AuthResponse
+      muId <- head <$> getRoot u
+      case _node_id <$> muId of
+        Nothing  -> pure InvalidUser
+        Just uid -> do
+          token <- makeTokenForUser uid
+          pure $ Valid token uid
+
+auth :: (HasSettings env, HasConnection env, HasJoseError err)
+     => AuthRequest -> Cmd' env err AuthResponse
 auth (AuthRequest u p) = do
   checkAuthRequest' <- checkAuthRequest u p
   case checkAuthRequest' of
@@ -90,9 +118,36 @@ auth (AuthRequest u p) = do
     InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
     Valid to trId   -> pure $ AuthResponse (Just $ AuthValid to trId) Nothing
 
+newtype AuthenticatedUser = AuthenticatedUser
+  { _authUser_id :: NodeId
+  } deriving (Generic)
+
+$(deriveJSON (unPrefix "_authUser_") ''AuthenticatedUser)
+instance ToSchema AuthenticatedUser where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authUser_")
+instance ToJWT AuthenticatedUser
+instance FromJWT AuthenticatedUser
+
+--type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
+
+-- TODO-SECURITY why is the CookieSettings necessary?
+type AuthContext = '[JWTSettings, CookieSettings] -- , BasicAuthCfg
+
+{-
+instance FromBasicAuthData AuthenticatedUser where
+  fromBasicAuthData authData authCheckFunction = authCheckFunction authData
+
+authCheck :: forall env. env
+          -> BasicAuthData
+          -> IO (AuthResult AuthenticatedUser)
+authCheck _env (BasicAuthData login password) = pure $
+  maybe Indefinite Authenticated $ TODO
+-}
+
 -- | Instances
 $(deriveJSON (unPrefix "_authReq_") ''AuthRequest)
-instance ToSchema AuthRequest
+instance ToSchema AuthRequest where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authReq_")
 
 instance Arbitrary AuthRequest where
   arbitrary = elements [ AuthRequest u p
@@ -101,23 +156,60 @@ instance Arbitrary AuthRequest where
                        ]
 
 $(deriveJSON (unPrefix "_authRes_") ''AuthResponse)
-instance ToSchema AuthResponse
+instance ToSchema AuthResponse where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authRes_")
 instance Arbitrary AuthResponse where
   arbitrary = oneof [ AuthResponse Nothing . Just      <$> arbitrary
                     , flip AuthResponse Nothing . Just <$> arbitrary ]
 
 $(deriveJSON (unPrefix "_authInv_") ''AuthInvalid)
-instance ToSchema AuthInvalid
+instance ToSchema AuthInvalid where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authInv_")
 instance Arbitrary AuthInvalid where
   arbitrary = elements [ AuthInvalid m 
                        | m <- [ "Invalid user", "Invalid password"]
                        ]
 
 $(deriveJSON (unPrefix "_authVal_") ''AuthValid)
-instance ToSchema AuthValid
+instance ToSchema AuthValid where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_authVal_")
 instance Arbitrary AuthValid where
   arbitrary = elements [ AuthValid to tr
                        | to <- ["token0", "token1"]
                        , tr <- [1..3]
                        ]
 
+data PathId = PathNode NodeId | PathNodeNode ListId DocId
+
+withAccessM :: (CmdM env err m, HasServerError err)
+            => UserId
+            -> PathId
+            -> m a
+            -> m a
+withAccessM uId (PathNode id) m = do
+  d <- id `isDescendantOf` NodeId uId
+  if d then m else m -- serverError err401
+
+withAccessM uId (PathNodeNode cId docId) m = do
+  _a <- isIn cId docId -- TODO use one query for all ?
+  _d <- cId `isDescendantOf` NodeId uId
+  if True -- a && d
+     then m
+     else m
+
+withAccess :: forall env err m api.
+              (GargServerC env err m, HasServer api '[]) =>
+              Proxy api -> Proxy m ->
+              UserId -> PathId ->
+              ServerT api m -> ServerT api m
+withAccess p _ uId id = hoistServer p f
+  where
+    f :: forall a. m a -> m a
+    f = withAccessM uId id
+
+{- | Collaborative Schema
+User at his root can create Teams Folder
+User can create Team in Teams Folder.
+User can invite User in Team as NodeNode only if Team in his parents.
+All users can access to the Team folder as if they were owner.
+-}

src/Gargantext/API/Corpus/New.hs

@@ -18,30 +18,44 @@ New corpus means either:
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE TypeOperators      #-}
 {-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE FlexibleContexts     #-}
-{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE RankNTypes         #-}
 
 module Gargantext.API.Corpus.New
       where
 
-import Data.Either
+--import Gargantext.Text.Corpus.Parsers (parseFile, FileFormat(..))
+import Control.Lens hiding (elements)
 import Control.Monad.IO.Class (liftIO)
+import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
+import Data.Maybe (fromMaybe)
+import Data.Either
 import Data.Swagger
 import Data.Text (Text)
 import GHC.Generics (Generic)
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.API.Corpus.New.File
+import Gargantext.API.Orchestrator.Types
+import Gargantext.Core (Lang(..))
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Database.Flow (FlowCmdM, flowCorpus)
 import Gargantext.Database.Flow (flowCorpusSearchInDatabase)
 import Gargantext.Database.Types.Node (CorpusId)
-import Gargantext.Text.Terms (TermType(..))
+import Gargantext.Database.Types.Node (ToHyperdataDocument(..))
+import Gargantext.Database.Types.Node (UserId)
 import Gargantext.Prelude
+import qualified Gargantext.Text.Corpus.Parsers as Parser (FileFormat(..), parseFormat)
+import Gargantext.Text.Terms (TermType(..))
 import Servant
+import Servant.API.Flatten (Flat)
+import Servant.Job.Core
+import Servant.Job.Types
+import Servant.Job.Utils (jsonOptions)
+import Servant.Multipart
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary
-import Gargantext.Core (Lang(..))
-import Gargantext.Database.Flow (FlowCmdM, flowCorpus)
+import Web.FormUrlEncoded          (FromForm)
 import qualified Gargantext.Text.Corpus.API as API
-import Gargantext.Database.Types.Node (UserId)
 
 data Query = Query { query_query      :: Text
                    , query_corpus_id  :: Int
@@ -60,9 +74,7 @@ instance Arbitrary Query where
                          ]
 
 instance ToSchema Query where
-  declareNamedSchema =
-    genericDeclareNamedSchema
-      defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 6 fieldLabel}
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_")
 
 type Api = Summary "New Corpus endpoint"
          :> ReqBody '[JSON] Query
@@ -70,8 +82,10 @@ type Api = Summary "New Corpus endpoint"
         :<|> Get '[JSON] ApiInfo
 
 -- | TODO manage several apis
-api :: (FlowCmdM env err m) => Query -> m CorpusId
-api (Query q _ as) = do
+-- TODO-ACCESS
+-- TODO this is only the POST
+api :: (FlowCmdM env err m) => UserId -> Query -> m CorpusId
+api _uId (Query q _ as) = do
   cId <- case head as of
     Nothing      -> flowCorpusSearchInDatabase "user1" EN q
     Just API.All -> flowCorpusSearchInDatabase "user1" EN q
@@ -95,4 +109,151 @@ instance ToSchema ApiInfo
 info :: FlowCmdM env err m => UserId -> m ApiInfo
 info _u = pure $ ApiInfo API.externalAPIs
 
+------------------------------------------------------------------------
+------------------------------------------------------------------------
+data WithQuery = WithQuery
+  { _wq_query     :: !Text
+  , _wq_databases :: ![ExternalAPIs]
+  , _wq_lang      :: !(Maybe Lang)
+  }
+  deriving Generic
+
+makeLenses ''WithQuery
+instance FromJSON WithQuery where
+  parseJSON = genericParseJSON $ jsonOptions "_wq_"
+instance ToSchema WithQuery where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wq_")
+
+-------------------------------------------------------
+data WithForm = WithForm
+  { _wf_filetype :: !FileType
+  , _wf_data     :: !Text
+  , _wf_lang     :: !(Maybe Lang)
+  } deriving (Eq, Show, Generic)
+
+makeLenses ''WithForm
+instance FromForm WithForm
+instance FromJSON WithForm where
+  parseJSON = genericParseJSON $ jsonOptions "_wf_"
+instance ToSchema WithForm where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wf_")
+
+------------------------------------------------------------------------
+type AsyncJobs event ctI input output =
+  Flat (AsyncJobsAPI' 'Unsafe 'Safe ctI '[JSON] Maybe event input output)
+------------------------------------------------------------------------
+
+type Upload = Summary "Corpus Upload endpoint"
+   :> "corpus"
+   :> Capture "corpus_id" CorpusId
+    :<|> "addWithquery" :> AsyncJobsAPI ScraperStatus WithQuery ScraperStatus
+    :<|> "addWithfile"  :> AsyncJobs ScraperStatus '[FormUrlEncoded] WithForm ScraperStatus
+
+
+type AddWithQuery = Summary "Add with Query to corpus endpoint"
+   :> "corpus"
+   :> Capture "corpus_id" CorpusId
+   :> "add"
+   :> "query"
+   :> "async"
+   :> AsyncJobsAPI ScraperStatus WithQuery ScraperStatus
+
+type AddWithFile = Summary "Add with MultipartData to corpus endpoint"
+   :> "corpus"
+   :> Capture "corpus_id" CorpusId
+   :> "add" 
+   :> "file"
+   :> MultipartForm Mem (MultipartData Mem)
+   :> QueryParam "fileType"  FileType
+   :> "async"
+   :> AsyncJobs ScraperStatus '[JSON] () ScraperStatus
+
+type AddWithForm = Summary "Add with FormUrlEncoded to corpus endpoint"
+   :> "corpus"
+   :> Capture "corpus_id" CorpusId
+   :> "add"
+   :> "form"
+   :> "async"
+   :> AsyncJobs ScraperStatus '[FormUrlEncoded] WithForm ScraperStatus
+
+------------------------------------------------------------------------
+-- TODO WithQuery also has a corpus id
+addToCorpusJobFunction :: FlowCmdM env err m
+                       => CorpusId
+                       -> WithQuery
+                       -> (ScraperStatus -> m ())
+                       -> m ScraperStatus
+addToCorpusJobFunction _cid (WithQuery _q _dbs _l) logStatus = do
+  -- TODO ...
+  logStatus ScraperStatus { _scst_succeeded = Just 10
+                          , _scst_failed    = Just 2
+                          , _scst_remaining = Just 138
+                          , _scst_events    = Just []
+                          }
+  -- TODO ...
+  pure      ScraperStatus { _scst_succeeded = Just 137
+                          , _scst_failed    = Just 13
+                          , _scst_remaining = Just 0
+                          , _scst_events    = Just []
+                          }
+
+
+addToCorpusWithFile :: FlowCmdM env err m
+                    => CorpusId
+                    -> MultipartData Mem
+                    -> Maybe FileType
+                    -> (ScraperStatus -> m ())
+                    -> m ScraperStatus
+addToCorpusWithFile cid input filetype logStatus = do
+  logStatus ScraperStatus { _scst_succeeded = Just 10
+                          , _scst_failed    = Just 2
+                          , _scst_remaining = Just 138
+                          , _scst_events    = Just []
+                          }
+  _h <- postUpload cid filetype input
+
+  pure      ScraperStatus { _scst_succeeded = Just 137
+                          , _scst_failed    = Just 13
+                          , _scst_remaining = Just 0
+                          , _scst_events    = Just []
+                          }
+
+addToCorpusWithForm :: FlowCmdM env err m
+                    => CorpusId
+                    -> WithForm
+                    -> (ScraperStatus -> m ())
+                    -> m ScraperStatus
+addToCorpusWithForm cid (WithForm ft d l) logStatus = do
+
+  printDebug "ft" ft
+
+  let
+    parse = case ft of
+      CSV_HAL   -> Parser.parseFormat Parser.CsvHal
+      CSV       -> Parser.parseFormat Parser.CsvGargV3
+      WOS       -> Parser.parseFormat Parser.WOS
+      PresseRIS -> Parser.parseFormat Parser.RisPresse
+
+  docs <- liftIO
+        $ splitEvery 500
+       <$> take 1000000
+       <$> parse (cs d)
+
+  logStatus ScraperStatus { _scst_succeeded = Just 1
+                          , _scst_failed    = Just 0
+                          , _scst_remaining = Just 1
+                          , _scst_events    = Just []
+                          }
+  cid' <- flowCorpus "user1"
+                     (Right [cid])
+                     (Multi $ fromMaybe EN l)
+                     (map (map toHyperdataDocument) docs)
+
+  printDebug "cid'" cid' 
+
+  pure      ScraperStatus { _scst_succeeded = Just 2
+                          , _scst_failed    = Just 0
+                          , _scst_remaining = Just 0
+                          , _scst_events    = Just []
+                          }
 

src/Gargantext/API/Corpus/New/File.hs

+{-|
+Module      : Gargantext.API.Corpus.New.File
+Description : Server API
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE NoImplicitPrelude    #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE RankNTypes           #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE TypeOperators        #-}
+
+module Gargantext.API.Corpus.New.File
+  where
+
+import Control.Lens ((.~), (?~))
+import Control.Monad (forM)
+import Control.Monad.IO.Class (liftIO)
+import Data.Maybe
+import Data.Aeson
+import Data.Monoid (mempty)
+import Data.Swagger
+import Data.Text (Text())
+import GHC.Generics (Generic)
+import Gargantext.API.Ngrams (TODO)
+import Gargantext.Database.Types.Node
+import Gargantext.Database.Utils -- (Cmd, CmdM)
+import Gargantext.Prelude
+import Gargantext.Prelude.Utils (sha)
+import Servant
+import Servant.Multipart
+import Servant.Swagger (HasSwagger(toSwagger))
+import Servant.Swagger.Internal
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+
+-------------------------------------------------------------
+type Hash = Text
+data FileType = CSV
+              | CSV_HAL
+              | PresseRIS
+              | WOS
+  deriving (Eq, Show, Generic)
+
+instance ToSchema FileType
+instance Arbitrary FileType
+  where
+    arbitrary = elements [CSV, PresseRIS]
+instance ToParamSchema FileType
+
+instance FromJSON FileType
+
+instance ToParamSchema (MultipartData Mem) where
+  toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
+
+instance FromHttpApiData FileType
+  where
+    parseUrlPiece "CSV"       = pure CSV
+    parseUrlPiece "CSV_HAL"   = pure CSV_HAL
+    parseUrlPiece "PresseRis" = pure PresseRIS
+    parseUrlPiece _           = pure CSV -- TODO error here
+
+
+instance (ToParamSchema a, HasSwagger sub) =>
+         HasSwagger (MultipartForm tag a :> sub) where
+  -- TODO
+  toSwagger _ = toSwagger (Proxy :: Proxy sub)
+              & addParam param
+    where
+      param = mempty
+            & required ?~ True
+            & schema   .~ ParamOther sch
+      sch = mempty
+          & in_         .~ ParamFormData
+          & paramSchema .~ toParamSchema (Proxy :: Proxy a)
+
+
+type WithUpload' = Summary "Upload file(s) to a corpus"
+                :> QueryParam "fileType"  FileType
+                :> MultipartForm Mem (MultipartData Mem)
+                :> Post '[JSON] [Hash]
+
+--postUpload :: NodeId -> Maybe FileType ->  GargServer UploadAPI
+--postUpload :: NodeId -> GargServer UploadAPI
+postUpload :: NodeId
+           -> Maybe FileType
+           -> MultipartData Mem
+           -> Cmd err [Hash]
+postUpload _ Nothing _ = panic "fileType is a required parameter"
+postUpload _ (Just fileType) multipartData = do
+  putStrLn $ "File Type: " <> (show fileType)
+  is <- liftIO $ do
+    putStrLn ("Inputs:" :: Text)
+    forM (inputs multipartData) $ \input -> do
+      putStrLn $ ("iName  " :: Text) <> (iName input)
+               <> ("iValue " :: Text) <> (iValue input)
+      pure $ iName input
+
+  _ <- forM (files multipartData) $ \file -> do
+    let content = fdPayload file
+    putStrLn $ ("XXX " :: Text) <> (fdFileName file)
+    putStrLn $ ("YYY " :: Text) <>  cs content
+    --pure $ cs content
+  -- is <- inputs multipartData
+
+  pure $ map (sha . cs) is
+
+-------------------------------------------------------------------

src/Gargantext/API/Count.hs

@@ -41,7 +41,7 @@ import Test.QuickCheck (elements)
 -- import Control.Applicative ((<*>))
 
 import Gargantext.Prelude
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 
 -----------------------------------------------------------------------
 -- TODO-ACCESS: CanCount
@@ -93,7 +93,9 @@ instance Arbitrary Query where
                          , n <- take 10 $ permutations scrapers
                          ]
 
-instance ToSchema Query
+instance ToSchema Query where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_")
+
 -----------------------------------------------------------------------
 type Code = Integer
 type Error  = Text
@@ -144,7 +146,8 @@ data Count = Count { count_name    :: Scraper
 
 $(deriveJSON (unPrefix "count_") ''Count)
 
-instance ToSchema Count
+instance ToSchema Count where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "count_")
 --instance Arbitrary Count where
 --    arbitrary = Count <$> arbitrary <*> arbitrary <*> arbitrary
 

src/Gargantext/API/Export.hs

+{-|
+Module      : Gargantext.API.Export
+Description : Get Metrics from Storage (Database like)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Main exports of Gargantext:
+- corpus
+- document and ngrams
+- lists
+
+-}
+
+
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeOperators     #-}
+
+module Gargantext.API.Export
+  where
+
+import Data.Aeson.TH (deriveJSON)
+import Data.Map (Map)
+import Data.Set (Set)
+import Data.Maybe (fromMaybe)
+import Data.Swagger
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import Gargantext.API.Ngrams
+import Gargantext.API.Ngrams.Tools (filterListWithRoot, mapTermListRoot, getRepo)
+import Gargantext.API.Types (GargNoServer)
+import Gargantext.Core.Types --
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Database.Config (userMaster)
+import Gargantext.Database.Metrics.NgramsByNode (getNgramsByNodeOnlyUser)
+import Gargantext.Database.Node.Select (selectNodesWithUsername)
+import Gargantext.Database.Schema.Ngrams (NgramsType(..))
+import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
+import Gargantext.Database.Schema.NodeNode (selectDocNodes)
+import Gargantext.Database.Types.Node (Node, HyperdataDocument(..), NodeId, ListId, CorpusId)
+import Gargantext.Database.Utils (Cmd)
+import Gargantext.Prelude
+import Gargantext.Prelude.Utils (sha)
+import Servant
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.List as List
+
+
+-- Corpus Export
+data Corpus =
+  Corpus { _c_corpus :: [Document]
+         , _c_hash   :: Hash
+         } deriving (Generic)
+
+-- | Document Export
+data Document =
+  Document { _d_document :: Node HyperdataDocument
+           , _d_ngrams   :: Ngrams
+           , _d_hash     :: Hash
+           } deriving (Generic)
+
+data Ngrams =
+  Ngrams { _ng_ngrams :: [Text]
+         , _ng_hash   :: Hash
+         } deriving (Generic)
+
+type Hash = Text
+-------
+instance ToSchema Corpus where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_c_")
+
+instance ToSchema Document where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_d_")
+
+instance ToSchema Ngrams where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ng_")
+
+-------
+instance ToParamSchema Corpus where
+  toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
+
+instance ToParamSchema Document where
+  toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
+
+instance ToParamSchema Ngrams where
+  toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
+--------------------------------------------------
+type API = Summary "Corpus Export"
+            :> "export"
+            :> QueryParam "listId"     ListId
+            :> QueryParam "ngramsType" NgramsType
+            :> Get '[JSON] Corpus
+
+--------------------------------------------------
+getCorpus :: CorpusId
+          -> Maybe ListId
+          -> Maybe NgramsType
+          -> GargNoServer Corpus
+getCorpus cId lId nt' = do
+
+  let
+    nt = case nt' of
+      Nothing -> NgramsTerms
+      Just  t -> t
+
+  ns   <- Map.fromList
+       <$> map (\n -> (_node_id n, n))
+       <$> selectDocNodes cId
+  repo <- getRepo
+  ngs  <- getNodeNgrams cId lId nt repo
+  let  -- uniqId is hash computed already for each document imported in database
+    r = Map.intersectionWith (\a b -> Document a (Ngrams (Set.toList b) (ng_hash b)) (d_hash a b)
+                             ) ns ngs
+          where
+            ng_hash b   = sha $ List.foldl (\x y -> x<>y) "" $ List.sort $ Set.toList b
+            d_hash  a b = sha $ (fromMaybe "" (_hyperdataDocument_uniqId $ _node_hyperdata a))
+                             <> (ng_hash b)
+
+  pure $ Corpus (Map.elems r) (sha $ List.foldl (\a b -> a<>b) ""
+                                   $ List.map _d_hash $ Map.elems r
+                              )
+
+getNodeNgrams :: HasNodeError err
+        => CorpusId
+        -> Maybe ListId
+        -> NgramsType
+        -> NgramsRepo
+        -> Cmd err (Map NodeId (Set Text))
+getNodeNgrams cId lId' nt repo = do
+  lId <- case lId' of
+    Nothing -> defaultList cId
+    Just  l -> pure l
+
+  lIds <- selectNodesWithUsername NodeList userMaster
+  let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
+  r <- getNgramsByNodeOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
+  pure r
+
+
+$(deriveJSON (unPrefix "_c_") ''Corpus)
+$(deriveJSON (unPrefix "_d_") ''Document)
+$(deriveJSON (unPrefix "_ng_") ''Ngrams)
+
+
+-- TODO
+-- Exports List
+-- Version number of the list
+
+

src/Gargantext/API/FrontEnd.hs

@@ -12,15 +12,16 @@ Loads all static file for the front-end.
 -}
 
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE TypeOperators        #-}
 
 ---------------------------------------------------------------------
 module Gargantext.API.FrontEnd where
 
-import Servant.Static.TH (createApiAndServerDecs)
+import Servant
+import Servant.Server.StaticFiles (serveDirectoryFileServer)
 
----------------------------------------------------------------------
-$(createApiAndServerDecs "FrontEndAPI" "frontEndServer" "purescript-gargantext/dist")
----------------------------------------------------------------------
+type FrontEndAPI = Raw
 
+frontEndServer :: Server FrontEndAPI
+frontEndServer = serveDirectoryFileServer "./purescript-gargantext/dist"

src/Gargantext/API/Metrics.hs

@@ -31,7 +31,7 @@ import Data.Time (UTCTime)
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Gargantext.Core.Types (ListType(..))
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Utils
 import Gargantext.Core.Types (CorpusId, ListId, Limit)
 import Gargantext.Prelude
@@ -50,7 +50,8 @@ data Metrics = Metrics
   { metrics_data :: [Metric]}
   deriving (Generic, Show)
 
-instance ToSchema Metrics
+instance ToSchema Metrics where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "metrics_")
 instance Arbitrary Metrics
   where
     arbitrary = Metrics <$> arbitrary
@@ -62,7 +63,8 @@ data Metric = Metric
   , m_cat   :: !ListType
   } deriving (Generic, Show)
 
-instance ToSchema Metric
+instance ToSchema Metric where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "m_")
 instance Arbitrary Metric
   where
     arbitrary = Metric <$> arbitrary
@@ -78,7 +80,8 @@ deriveJSON (unPrefix "m_") ''Metric
 data ChartMetrics a = ChartMetrics { chartMetrics_data :: a }
   deriving (Generic, Show)
 
-instance (ToSchema a) => ToSchema (ChartMetrics a)
+instance (ToSchema a) => ToSchema (ChartMetrics a) where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "chartMetrics_")
 instance (Arbitrary a) => Arbitrary (ChartMetrics a)
   where
     arbitrary = ChartMetrics <$> arbitrary
@@ -86,7 +89,8 @@ instance (Arbitrary a) => Arbitrary (ChartMetrics a)
 deriveJSON (unPrefix "chartMetrics_") ''ChartMetrics
 
 -------------------------------------------------------------
-instance ToSchema Histo
+instance ToSchema Histo where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "histo_")
 instance Arbitrary Histo
   where
     arbitrary = elements [ Histo ["2012"] [1]
@@ -95,11 +99,6 @@ instance Arbitrary Histo
 deriveJSON (unPrefix "histo_") ''Histo
 
 
-instance ToSchema MyTree
-instance Arbitrary MyTree
-  where
-    arbitrary = MyTree <$> arbitrary <*> arbitrary <*> arbitrary
-
 
 -------------------------------------------------------------
 -- | Scatter metrics API

src/Gargantext/API/Ngrams/NTree.hs

@@ -23,16 +23,18 @@ import Data.Text (Text)
 import Gargantext.Prelude
 import GHC.Generics (Generic)
 import Data.Aeson.TH (deriveJSON)
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Core.Types (ListType(..), NodeId)
 import Gargantext.API.Ngrams
 import Data.Tree
 import Data.Maybe (catMaybes)
 import Data.Map (Map)
 import Data.Set (Set)
+import Data.Swagger
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.List as List
+import Test.QuickCheck
 
 type Children = Text
 type Root = Text
@@ -47,12 +49,17 @@ toMyTree (Node (l,v) xs) = MyTree l v (map toMyTree xs)
 
 deriveJSON (unPrefix "mt_") ''MyTree
 
+instance ToSchema MyTree where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_")
+instance Arbitrary MyTree
+  where
+    arbitrary = MyTree <$> arbitrary <*> arbitrary <*> arbitrary
 
 toTree :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [MyTree]
 toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
   where
     buildNode r = maybe ((r, value r),[]) (\x -> ((r, value r), mSetToList $ _nre_children x)) (Map.lookup r m)
-    
+
     value l = maybe 0 (fromIntegral . Set.size) $ Map.lookup l vs
 
     rootsCandidates = catMaybes
@@ -60,7 +67,7 @@ toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
                     $ map (\(c,c') -> case _nre_root c' of
                                        Nothing -> Just c
                                        _ -> _nre_root c' ) (Map.toList m)
-    
+
     roots = map fst
           $ filter (\(_,l) -> l == lt)
           $ catMaybes

src/Gargantext/API/Ngrams/Tools.hs

@@ -33,20 +33,28 @@ import qualified Data.Set as Set
 
 type RootTerm = Text
 
-getListNgrams :: RepoCmdM env err m
-               => [ListId] -> NgramsType
-               -> m (Map Text NgramsRepoElement)
-getListNgrams nodeIds ngramsType = do
-  v    <- view repoVar
-  repo <- liftIO $ readMVar v
-
-  let
+getRepo :: RepoCmdM env err m => m NgramsRepo
+getRepo = do
+  v <- view repoVar
+  liftIO $ readMVar v
+
+listNgramsFromRepo :: [ListId] -> NgramsType
+                   -> NgramsRepo -> Map Text NgramsRepoElement
+listNgramsFromRepo nodeIds ngramsType repo = ngrams
+  where
     ngramsMap = repo ^. r_state . at ngramsType . _Just
 
     ngrams    = Map.unionsWith mergeNgramsElement
               [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
 
-  pure ngrams
+-- TODO-ACCESS: We want to do the security check before entering here.
+--              Add a static capability parameter would be nice.
+--              Ideally this is the access to `repoVar` which needs to
+--              be properly guarded.
+getListNgrams :: RepoCmdM env err m
+              => [ListId] -> NgramsType
+              -> m (Map Text NgramsRepoElement)
+getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
 
 getTermsWith :: (RepoCmdM env err m, Ord a)
           => (Text -> a ) -> [ListId]
@@ -57,19 +65,19 @@ getTermsWith f ls ngt lt = Map.fromListWith (<>)
                       <$> Map.toList
                       <$> Map.filter (\f' -> (fst f') == lt)
                       <$> mapTermListRoot ls ngt
+                      <$> getRepo
   where
     toTreeWith f'' (t, (_lt, maybeRoot)) = case maybeRoot of
       Nothing -> (f'' t, [])
       Just  r -> (f'' r, map f'' [t])
 
-mapTermListRoot :: RepoCmdM env err m
-               => [ListId] -> NgramsType
-               -> m (Map Text (ListType, (Maybe Text)))
-mapTermListRoot nodeIds ngramsType = do
-  ngrams <- getListNgrams nodeIds ngramsType
-  pure $ Map.fromList [ (t, (_nre_list nre, _nre_root nre))
-                      | (t, nre) <- Map.toList ngrams
-                      ]
+mapTermListRoot :: [ListId] -> NgramsType
+                -> NgramsRepo -> Map Text (ListType, (Maybe Text))
+mapTermListRoot nodeIds ngramsType repo =
+  Map.fromList [ (t, (_nre_list nre, _nre_root nre))
+               | (t, nre) <- Map.toList ngrams
+               ]
+  where ngrams = listNgramsFromRepo nodeIds ngramsType repo
 
 filterListWithRoot :: ListType -> Map Text (ListType, Maybe Text)
                       -> Map Text (Maybe RootTerm)

src/Gargantext/API/Orchestrator._hs → src/Gargantext/API/Orchestrator.hs

@@ -66,10 +66,14 @@ pipeline scrapyurl client_env input log_status = do
   e <- runJobMLog client_env log_status $ callScraper scrapyurl input
   either (panic . cs . show) pure e -- TODO throwError
 
+-- TODO integrate to ServerT
+--  use:
+--  * serveJobsAPI instead of simpleServeJobsAPI
+--  * JobFunction  instead of simpleJobFunction
 scrapyOrchestrator :: Env -> IO (Server (WithCallbacks ScraperAPI))
 scrapyOrchestrator env = do
   apiWithCallbacksServer (Proxy :: Proxy ScraperAPI)
     defaultSettings (extendBaseUrl ("scraper" :: String) $ env ^. env_self_url)
     (env ^. env_manager) (LogEvent logConsole) $
-    serveJobsAPI (env ^. env_scrapers) .
-      JobFunction . pipeline (URL $ env ^. env_settings . scrapydUrl)
+    simpleServeJobsAPI (env ^. env_scrapers) .
+      simpleJobFunction . pipeline (URL $ env ^. env_settings . scrapydUrl)

src/Gargantext/API/Orchestrator/Types._hs → src/Gargantext/API/Orchestrator/Types.hs

@@ -13,37 +13,53 @@ module Gargantext.API.Orchestrator.Types where
 import Gargantext.Prelude
 import Control.Lens hiding (elements)
 import Data.Aeson
+import Data.Proxy
 import Data.Text (Text)
 import Data.Swagger hiding (URL, url, port)
 import GHC.Generics hiding (to)
 import Servant.Job.Async
-import Servant.Job.Client
 import Servant.Job.Types
 import Servant.Job.Utils (jsonOptions)
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary
-
+import Gargantext.Core.Types (TODO(..))
 instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where
   arbitrary = panic "TODO"
 
 instance Arbitrary a => Arbitrary (JobOutput a) where
   arbitrary = JobOutput <$> arbitrary
 
-instance ToSchema URL where
-  declareNamedSchema = panic "TODO"
+-- | Main Types
+data ExternalAPIs = All
+                  | PubMed
+
+                  | HAL_EN
+                  | HAL_FR
+
+                  | IsTex_EN
+                  | IsTex_FR
 
-instance ToSchema AnyOutput where
-  declareNamedSchema = panic "TODO"
+                  | Isidore_EN
+                  | Isidore_FR
+                  -- | IsidoreAuth
+  deriving (Show, Eq, Enum, Bounded, Generic)
 
-instance ToSchema AnyInput where
-  declareNamedSchema = panic "TODO"
 
-instance ToSchema AnyEvent where
-  declareNamedSchema = panic "TODO"
+-- | Main Instances
+instance FromJSON ExternalAPIs
+instance ToJSON ExternalAPIs
 
-instance ToSchema a => ToSchema (JobInput a)
+externalAPIs :: [ExternalAPIs]
+externalAPIs = [minBound..maxBound]
 
-instance ToSchema a => ToSchema (JobOutput a)
+instance Arbitrary ExternalAPIs
+  where
+    arbitrary = elements externalAPIs
+
+instance ToSchema ExternalAPIs
+
+instance ToSchema URL where
+  declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
 
 data ScraperInput = ScraperInput
   { _scin_spider       :: !Text
@@ -62,6 +78,8 @@ makeLenses ''ScraperInput
 instance FromJSON ScraperInput where
   parseJSON = genericParseJSON $ jsonOptions "_scin_"
 
+-- Proposal to replace the Corpus.API.Query type which seems to generically named.
+
 data ScraperEvent = ScraperEvent
   { _scev_message :: !(Maybe Text)
   , _scev_level   :: !(Maybe Text)
@@ -89,7 +107,11 @@ data ScraperStatus = ScraperStatus
   deriving Generic
 
 instance Arbitrary ScraperStatus where
-  arbitrary = ScraperStatus <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+  arbitrary = ScraperStatus
+           <$> arbitrary
+           <*> arbitrary
+           <*> arbitrary
+           <*> arbitrary
 
 instance ToJSON ScraperStatus where
   toJSON = genericToJSON $ jsonOptions "_scst_"
@@ -102,12 +124,12 @@ instance ToSchema ScraperStatus -- TODO _scst_ prefix
 instance ToSchema ScraperInput  -- TODO _scin_ prefix
 instance ToSchema ScraperEvent  -- TODO _scev_ prefix
 
-instance ToParamSchema Offset where
-  toParamSchema = panic "TODO"
+instance ToParamSchema Offset -- where
+  -- toParamSchema = panic "TODO"
 
-instance ToParamSchema Limit where
-  toParamSchema = panic "TODO"
+instance ToParamSchema Limit -- where
+  -- toParamSchema = panic "TODO"
 
 type ScrapersEnv = JobEnv ScraperStatus ScraperStatus
 
-type ScraperAPI = AsyncJobsAPI ScraperStatus ScraperInput ScraperStatus
+type ScraperAPI  = AsyncJobsAPI ScraperStatus ScraperInput  ScraperStatus

src/Gargantext/API/Search.hs

@@ -12,6 +12,7 @@ Count API part of Gargantext.
 
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
+{-# LANGUAGE FlexibleContexts   #-}
 {-# LANGUAGE NoImplicitPrelude  #-}
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE TemplateHaskell    #-}
@@ -35,7 +36,7 @@ import Test.QuickCheck (elements)
 -- import Control.Applicative ((<*>))
 import Gargantext.API.Types (GargServer)
 import Gargantext.Prelude
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Types.Node
 import Gargantext.Database.TextSearch
 import Gargantext.Database.Facet
@@ -48,9 +49,7 @@ data SearchQuery = SearchQuery
 $(deriveJSON (unPrefix "sq_") ''SearchQuery)
 
 instance ToSchema SearchQuery where
-  declareNamedSchema =
-    genericDeclareNamedSchema
-      defaultSchemaOptions {fieldLabelModifier = drop 3}
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "sq_")
 
 instance Arbitrary SearchQuery where
   arbitrary = elements [SearchQuery ["electrodes"]]
@@ -64,11 +63,10 @@ instance Arbitrary SearchDocResults where
   arbitrary = SearchDocResults <$> arbitrary
 
 instance ToSchema SearchDocResults where
-  declareNamedSchema =
-    genericDeclareNamedSchema
-      defaultSchemaOptions {fieldLabelModifier = drop 4}
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "sdr_")
 
-data SearchPairedResults = SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]] }
+data SearchPairedResults =
+     SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]] }
   deriving (Generic)
 $(deriveJSON (unPrefix "spr_") ''SearchPairedResults)
 
@@ -76,32 +74,33 @@ instance Arbitrary SearchPairedResults where
   arbitrary = SearchPairedResults <$> arbitrary
 
 instance ToSchema SearchPairedResults where
-  declareNamedSchema =
-    genericDeclareNamedSchema
-      defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "spr_")
 
 -----------------------------------------------------------------------
 -- TODO-ACCESS: CanSearch? or is it part of CanGetNode
 -- TODO-EVENTS: No event, this is a read-only query.
-type SearchAPI results
-  = Summary "Search endpoint"
- :> ReqBody '[JSON] SearchQuery
- :> QueryParam "offset" Int
- :> QueryParam "limit"  Int
- :> QueryParam "order"  OrderBy
- :> Post '[JSON] results
+type SearchAPI results = Summary "Search endpoint"
+                       :> ReqBody '[JSON] SearchQuery
+                       :> QueryParam "offset" Int
+                       :> QueryParam "limit"  Int
+                       :> QueryParam "order"  OrderBy
+                       :> Post '[JSON] results
 
 type SearchDocsAPI  = SearchAPI SearchDocResults
-type SearchPairsAPI = SearchAPI SearchPairedResults
------------------------------------------------------------------------
-
-searchPairs :: NodeId -> GargServer SearchPairsAPI
-searchPairs pId (SearchQuery q) o l order =
-  SearchPairedResults <$> searchInCorpusWithContacts pId q o l order
-
 searchDocs :: NodeId -> GargServer SearchDocsAPI
 searchDocs nId (SearchQuery q) o l order =
   SearchDocResults <$> searchInCorpus nId False q o l order
   --SearchResults <$> searchInCorpusWithContacts nId q o l order
 
+-----------------------------------------------------------------------
+type SearchPairsAPI = Summary ""
+                    :> "list"
+                    :> Capture "list" ListId
+                    :> SearchAPI SearchPairedResults
+searchPairs :: NodeId -> GargServer SearchPairsAPI
+
+searchPairs pId lId (SearchQuery q) o l order =
+  SearchPairedResults <$> searchInCorpusWithContacts pId lId q o l order
+
+-----------------------------------------------------------------------
 

src/Gargantext/API/Settings.hs

@@ -6,6 +6,8 @@ License     : AGPL + CECILL v3
 Maintainer  : team@gargantext.org
 Stability   : experimental
 Portability : POSIX
+
+TODO-SECURITY: Critical
 -}
 
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -14,6 +16,7 @@ Portability : POSIX
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude   #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RankNTypes          #-}
@@ -40,16 +43,16 @@ import Data.Aeson
 import Data.Maybe (fromMaybe)
 import Data.Either (either)
 import Data.Text
-import Data.Text.Encoding (encodeUtf8)
+--import Data.Text.Encoding (encodeUtf8)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as L
 
 import Servant
+import Servant.Auth.Server (defaultJWTSettings, JWTSettings, CookieSettings, defaultCookieSettings, readKey, writeKey)
 import Servant.Client (BaseUrl, parseBaseUrl)
---import Servant.Job.Async (newJobEnv, defaultSettings)
+import qualified Servant.Job.Core
+import Servant.Job.Async (newJobEnv, defaultSettings, HasJobEnv(..), Job)
 import Web.HttpApiData (parseUrlPiece)
-import qualified Jose.Jwk as Jose
-import qualified Jose.Jwa as Jose
 
 import Control.Concurrent
 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
@@ -60,7 +63,7 @@ import Control.Lens
 import Gargantext.Prelude
 import Gargantext.Database.Utils (databaseParameters, HasConnection(..), Cmd', runCmd)
 import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_var, renv_lock)
---import Gargantext.API.Orchestrator.Types
+import Gargantext.API.Orchestrator.Types
 
 type PortNumber = Int
 
@@ -77,7 +80,8 @@ data Settings = Settings
     , _logLevelLimit   :: LogLevel -- log level from the monad-logger package
 --    , _dbServer        :: Text
 --    ^ this is not used yet
-    , _jwtSecret       :: Jose.Jwk -- key from the jose-jwt package
+    , _jwtSettings     :: JWTSettings
+    , _cookieSettings  :: CookieSettings
     , _sendLoginEmails :: SendEmailType
     , _scrapydUrl      :: BaseUrl
     , _fileFolder      :: FilePath
@@ -88,30 +92,22 @@ makeLenses ''Settings
 class HasSettings env where
   settings :: Getter env Settings
 
-
-parseJwk :: Text -> Jose.Jwk
-parseJwk secretStr = jwk
-    where
-        secretBs = encodeUtf8 secretStr
-        jwk      = Jose.SymmetricJwk secretBs 
-                                     Nothing 
-                                     Nothing 
-                                     (Just $ Jose.Signed Jose.HS256)
-
-devSettings :: Settings
-devSettings = Settings
+devSettings :: FilePath -> IO Settings
+devSettings jwkFile = do
+  jwkExists <- doesFileExist jwkFile
+  when (not jwkExists) $ writeKey jwkFile
+  jwk <- readKey jwkFile
+  pure $ Settings
     { _allowedOrigin = "http://localhost:8008"
     , _allowedHost = "localhost:3000"
     , _appPort = 3000
     , _logLevelLimit = LevelDebug
 --    , _dbServer = "localhost"
-    -- generate with dd if=/dev/urandom bs=1 count=32 | base64
-    -- make sure jwtSecret differs between development and production, because you do not want
-    -- your production key inside source control.
-    , _jwtSecret = parseJwk "MVg0YAPVSPiYQc/qIs/rV/X32EFR0zOJWfHFgMbszMw="
     , _sendLoginEmails = LogEmailToConsole
     , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
     , _fileFolder = "data"
+    , _cookieSettings = defaultCookieSettings -- TODO-SECURITY tune
+    , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
     }
 
 
@@ -147,7 +143,7 @@ data Env = Env
   , _env_repo     :: !RepoEnv
   , _env_manager  :: !Manager
   , _env_self_url :: !BaseUrl
-  --, _env_scrapers :: !ScrapersEnv
+  , _env_scrapers :: !ScrapersEnv
   }
   deriving (Generic)
 
@@ -168,6 +164,12 @@ instance HasRepo Env where
 instance HasSettings Env where
   settings = env_settings
 
+instance Servant.Job.Core.HasEnv Env (Job ScraperStatus ScraperStatus) where
+  _env = env_scrapers . Servant.Job.Core._env
+
+instance HasJobEnv Env ScraperStatus ScraperStatus where
+  job_env = env_scrapers
+
 data MockEnv = MockEnv
   { _menv_firewall :: !FireWall
   }
@@ -176,14 +178,18 @@ data MockEnv = MockEnv
 makeLenses ''MockEnv
 
 -- | TODO add this path in Settings
+
+repoDir :: FilePath
+repoDir = "repos"
+
 repoSnapshot :: FilePath
-repoSnapshot = "repo.json"
+repoSnapshot = repoDir <> "/repo.json"
 
 -- | TODO add hard coded file in Settings
 -- This assumes we own the lock on repoSnapshot.
 repoSaverAction :: ToJSON a => a -> IO ()
 repoSaverAction a = do
-  withTempFile "." "tmp-repo.json" $ \fp h -> do
+  withTempFile "repos" "tmp-repo.json" $ \fp h -> do
     -- printDebug "repoSaverAction" fp
     L.hPut h $ encode a
     hClose h
@@ -208,6 +214,8 @@ mkRepoSaver repo_var = mkDebounce settings
 readRepoEnv :: IO RepoEnv
 readRepoEnv = do
   -- Does file exist ? :: Bool
+  _repoDir <- createDirectoryIfMissing True repoDir
+
   repoFile <- doesFileExist repoSnapshot
 
   -- Is file not empty ? :: Bool
@@ -228,14 +236,17 @@ readRepoEnv = do
         pure repo
       else
         pure initRepo
-
+  -- TODO save in DB here
   saver <- mkRepoSaver mvar
   pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
 
+devJwkFile :: FilePath
+devJwkFile = "dev.jwk"
+
 newEnv :: PortNumber -> FilePath -> IO Env
 newEnv port file = do
   manager <- newTlsManager
-  settings <- pure (devSettings & appPort .~ port) -- TODO read from 'file'
+  settings <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
   when (port /= settings ^. appPort) $
     panic "TODO: conflicting settings of port"
 
@@ -243,7 +254,7 @@ newEnv port file = do
   param    <- databaseParameters file
   conn     <- connect param
   repo     <- readRepoEnv
-  --scrapers_env <- newJobEnv defaultSettings manager
+  scrapers_env <- newJobEnv defaultSettings manager
   logger <- newStderrLoggerSet defaultBufSize
 
   pure $ Env
@@ -252,7 +263,7 @@ newEnv port file = do
     , _env_conn       = conn
     , _env_repo       = repo
     , _env_manager    = manager
-    --, _env_scrapers   = scrapers_env
+    , _env_scrapers   = scrapers_env
     , _env_self_url   = self_url
     }
 
@@ -295,10 +306,11 @@ withDevEnv iniPath k = do
       param <- databaseParameters iniPath
       conn  <- connect param
       repo  <- readRepoEnv
+      setts <- devSettings devJwkFile
       pure $ DevEnv
         { _dev_env_conn = conn
         , _dev_env_repo = repo
-        , _dev_env_settings = devSettings
+        , _dev_env_settings = setts
         }
 
 -- | Run Cmd Sugar for the Repl (GHCI)

src/Gargantext/API/Table.hs

@@ -44,9 +44,9 @@ import Data.Swagger
 import Data.Text (Text())
 import GHC.Generics (Generic)
 import Gargantext.API.Ngrams (TabType(..))
-import Gargantext.Core.Types (Offset, Limit)
-import Gargantext.Core.Utils.Prefix (unPrefix)
-import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),runViewAuthorsDoc)
+import Gargantext.Core.Types (Offset, Limit, TableResult(..))
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..), runViewAuthorsDoc)
 import Gargantext.Database.Learn (FavOrTrash(..), moreLike)
 import Gargantext.Database.TextSearch
 import Gargantext.Database.Types.Node
@@ -57,11 +57,11 @@ import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
 ------------------------------------------------------------------------
+
 type TableApi = Summary " Table API"
               :> ReqBody '[JSON] TableQuery
-              :> Post '[JSON] [FacetDoc]
+              :> Post    '[JSON] FacetTableResult
 
---{-
 data TableQuery = TableQuery
   { tq_offset  :: Int
   , tq_limit   :: Int
@@ -70,42 +70,64 @@ data TableQuery = TableQuery
   , tq_query  :: Text
   } deriving (Generic)
 
+type FacetTableResult = TableResult FacetDoc
+
 $(deriveJSON (unPrefix "tq_") ''TableQuery)
 
 instance ToSchema TableQuery where
-  declareNamedSchema =
-    genericDeclareNamedSchema
-      defaultSchemaOptions {fieldLabelModifier = drop 3}
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "tq_")
 
 instance Arbitrary TableQuery where
   arbitrary = elements [TableQuery 0 10 DateAsc Docs "electrodes"]
 
 
-tableApi :: NodeId -> TableQuery -> Cmd err [FacetDoc]
+tableApi :: NodeId -> TableQuery -> Cmd err FacetTableResult
 tableApi cId (TableQuery o l order ft "") = getTable cId (Just ft) (Just o) (Just l) (Just order)
 tableApi cId (TableQuery o l order ft q) = case ft of
-      Docs  -> searchInCorpus cId False [q] (Just o) (Just l) (Just order)
-      Trash -> searchInCorpus cId True [q] (Just o) (Just l) (Just order)
+      Docs  -> searchInCorpus' cId False [q] (Just o) (Just l) (Just order)
+      Trash -> searchInCorpus' cId True [q] (Just o) (Just l) (Just order)
       x     -> panic $ "not implemented in tableApi " <> (cs $ show x)
 
+searchInCorpus' :: CorpusId
+                -> Bool
+                -> [Text]
+                -> Maybe Offset
+                -> Maybe Limit
+                -> Maybe OrderBy
+                -> Cmd err FacetTableResult
+searchInCorpus' cId t q o l order = do
+  docs <- searchInCorpus cId t q o l order
+  countAllDocs  <- searchCountInCorpus cId t q
+  pure $ TableResult { tr_docs = docs, tr_count = countAllDocs }
+
+
 getTable :: NodeId -> Maybe TabType
+         -> Maybe Offset  -> Maybe Limit
+         -> Maybe OrderBy -> Cmd err FacetTableResult
+getTable cId ft o l order = do
+  docs <- getTable' cId ft o l order
+  -- TODO: Rewrite to use runCountOpaQuery and avoid (length allDocs)
+  allDocs  <- getTable' cId ft Nothing Nothing Nothing
+  pure $ TableResult { tr_docs = docs, tr_count = length allDocs }
+
+getTable' :: NodeId -> Maybe TabType
          -> Maybe Offset  -> Maybe Limit
          -> Maybe OrderBy -> Cmd err [FacetDoc]
-getTable cId ft o l order =
+getTable' cId ft o l order =
   case ft of
-    (Just Docs)  -> runViewDocuments cId False o l order
-    (Just Trash) -> runViewDocuments cId True  o l order
+    (Just Docs)      -> runViewDocuments cId False o l order
+    (Just Trash)     -> runViewDocuments cId True  o l order
     (Just MoreFav)   -> moreLike cId o l order IsFav
     (Just MoreTrash) -> moreLike cId o l order IsTrash
     x     -> panic $ "not implemented in getTable: " <> (cs $ show x)
 
-getPairing :: ContactId -> Maybe TabType
+
+getPair :: ContactId -> Maybe TabType
          -> Maybe Offset  -> Maybe Limit
          -> Maybe OrderBy -> Cmd err [FacetDoc]
-getPairing cId ft o l order =
+getPair cId ft o l order =
   case ft of
     (Just Docs)  -> runViewAuthorsDoc cId False o l order
     (Just Trash) -> runViewAuthorsDoc cId True  o l order
     _     -> panic $ "not implemented: get Pairing" <> (cs $ show ft)
 
-

src/Gargantext/API/Types.hs

@@ -10,32 +10,129 @@ Portability : POSIX
 -}
 
 
-{-# LANGUAGE NoImplicitPrelude  #-}
-{-# LANGUAGE RankNTypes         #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE NoImplicitPrelude      #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
 
 module Gargantext.API.Types
+  ( module Gargantext.API.Types
+  , HasServerError(..)
+  , serverError
+  )
   where
 
+import Control.Exception (Exception)
+import Control.Lens (Prism', (#))
+import Control.Lens.TH (makePrisms)
+import Control.Monad.Error.Class (MonadError(throwError))
+import Crypto.JOSE.Error as Jose
+import Data.Aeson.Types
+import Data.Typeable
+import Data.Validity
 import Servant
+import Servant.Job.Core (HasServerError(..), serverError)
+import Servant.Job.Async (HasJobEnv)
+import Gargantext.Prelude
 import Gargantext.API.Settings
+import Gargantext.API.Orchestrator.Types
 import Gargantext.API.Ngrams
-import Gargantext.Database.Tree
 import Gargantext.Core.Types
+import Gargantext.Database.Tree
 import Gargantext.Database.Utils
 import Gargantext.Database.Schema.Node
 
+class HasJoseError e where
+  _JoseError :: Prism' e Jose.Error
 
-type GargServer api =
-  forall env err m.
-    ( CmdM env err m
-    , HasNodeError err
-    , HasInvalidError err
-    , HasTreeError err
-    , HasRepo env
-    , HasSettings env
+joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
+joseError = throwError . (_JoseError #)
+
+class ThrowAll' e a | a -> e where
+  -- | 'throwAll' is a convenience function to throw errors across an entire
+  -- sub-API
+  --
+  --
+  -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
+  -- >    == throwError err400 :<|> throwError err400 :<|> err400
+  throwAll' :: e -> a
+
+instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
+  throwAll' e = throwAll' e :<|> throwAll' e
+
+-- Really this shouldn't be necessary - ((->) a) should be an instance of
+-- MonadError, no?
+instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
+  throwAll' e = const $ throwAll' e
+
+instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
+  throwAll' = throwError
+
+type GargServerC env err m =
+    ( CmdM         env err m
+    , HasNodeError     err
+    , HasInvalidError  err
+    , HasTreeError     err
+    , HasServerError   err
+    , HasJoseError     err
+    , ToJSON           err -- TODO this is arguable
+    , Exception        err
+    , HasRepo      env
+    , HasSettings  env
+    , HasJobEnv    env ScraperStatus ScraperStatus
     )
-    => ServerT api m
 
+type GargServerT env err m api = GargServerC env err m => ServerT api m
+
+type GargServer api =
+  forall env err m. GargServerT env err m api
+
+-------------------------------------------------------------------
+-- | This Type is needed to prepare the function before the GargServer
+type GargNoServer' env err m =
+  ( CmdM           env err m
+  , HasRepo        env
+  , HasSettings    env
+  , HasNodeError       err
+  )
+
+type GargNoServer t =
+  forall env err m. GargNoServer' env err m => m t
+-------------------------------------------------------------------
+
+data GargError
+  = GargNodeError    NodeError
+  | GargTreeError    TreeError
+  | GargInvalidError Validation
+  | GargJoseError    Jose.Error
+  | GargServerError  ServerError
+  deriving (Show, Typeable)
+
+makePrisms ''GargError
+
+instance ToJSON GargError where
+  toJSON _ = String "SomeGargErrorPleaseReport"
+
+instance Exception GargError
+
+instance HasNodeError GargError where
+  _NodeError = _GargNodeError
+
+instance HasInvalidError GargError where
+  _InvalidError = _GargInvalidError
 
+instance HasTreeError GargError where
+  _TreeError = _GargTreeError
 
+instance HasServerError GargError where
+  _ServerError = _GargServerError
 
+instance HasJoseError GargError where
+  _JoseError = _GargJoseError

src/Gargantext/API/Utils.hs

@@ -21,22 +21,6 @@ import Gargantext.Prelude
 import Data.Maybe (Maybe, fromMaybe)
 import Prelude (String)
 import qualified Data.Text as T
-import Data.Swagger
-import Data.Text (Text)
-
-
-
-swaggerOptions :: Text -> SchemaOptions
-swaggerOptions pref = defaultSchemaOptions
-  { Data.Swagger.fieldLabelModifier = modifier pref
-  , Data.Swagger.unwrapUnaryRecords = False
-  }
-
-
-modifier :: Text -> String -> String
-modifier pref field = T.unpack
-                    $ T.stripPrefix pref (T.pack field) ?! "Expecting prefix " <> T.unpack pref
-
 
 infixr 4 ?|
 

src/Gargantext/Core.hs

@@ -9,11 +9,20 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE NoImplicitPrelude  #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 module Gargantext.Core
   where
 
-
-
+import Gargantext.Prelude
+import GHC.Generics (Generic)
+import Data.Aeson
+import Data.Either(Either(Left))
+import Data.Swagger
+import Servant.API
 ------------------------------------------------------------------------
 -- | Language of a Text
 -- For simplicity, we suppose text has an homogenous language
@@ -30,9 +39,17 @@ module Gargantext.Core
 
 -- | All languages supported
 -- TODO : DE | SP | CH
-data Lang = EN | FR
-  deriving (Show, Eq, Ord, Bounded, Enum)
-
+data Lang = EN | FR | All
+  deriving (Show, Eq, Ord, Bounded, Enum, Generic)
 
+instance ToJSON Lang
+instance FromJSON Lang
+instance ToSchema Lang
+instance FromHttpApiData Lang
+  where
+    parseUrlPiece "EN" = pure EN
+    parseUrlPiece "FR" = pure FR
+    parseUrlPiece "All" = pure All
+    parseUrlPiece _            = Left "Unexpected value of OrderBy"
 allLangs :: [Lang]
 allLangs = [minBound ..]

src/Gargantext/Core/Flow.hs → src/Gargantext/Core/Flow/Types.hs

 {-|
-Module      : Gargantext.Core.Flow
+Module      : Gargantext.Core.Flow.Types
 Description : Core Flow main Types
 Copyright   : (c) CNRS, 2017-Present
 License     : AGPL + CECILL v3
@@ -13,7 +13,7 @@ Portability : POSIX
 {-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE ConstrainedClassMethods #-}
 
-module Gargantext.Core.Flow where
+module Gargantext.Core.Flow.Types where
 
 import Control.Lens (Lens')
 import Data.Map (Map)
@@ -40,14 +40,15 @@ class UniqId a
 
 class ExtractNgramsT h
   where
-    extractNgramsT :: HasText h => TermType Lang -> h -> Cmd err (Map Ngrams (Map NgramsType Int))
+    extractNgramsT :: HasText h
+                   => TermType Lang
+                   -> h
+                   -> Cmd err (Map Ngrams (Map NgramsType Int))
 
 class HasText h
   where
     hasText :: h -> [Text]
 
-------------------------------------------------------------------------
-
 instance UniqId HyperdataDocument
   where
     uniqId = hyperdataDocument_uniqId
@@ -55,5 +56,3 @@ instance UniqId HyperdataDocument
 instance UniqId HyperdataContact
   where
     uniqId = hc_uniqId
-
-

src/Gargantext/Core/Types.hs

@@ -14,6 +14,7 @@ commentary with @some markup@.
 ------------------------------------------------------------------------
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE TemplateHaskell      #-}
 
 module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
                              , module Gargantext.Database.Types.Node
@@ -22,27 +23,31 @@ module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
                              , Label, Stems
                              , HasInvalidError(..), assertValid
                              , Name
+                             , TableResult(..)
+                             , NodeTableResult
+                             , TODO(..)
                              ) where
 
+--import qualified Data.Set as S
 import Control.Lens (Prism', (#))
 import Control.Monad.Error.Class (MonadError, throwError)
-
 import Data.Aeson
-import Data.Semigroup
+import Data.Aeson.TH (deriveJSON)
 import Data.Monoid
+import Data.Semigroup
 import Data.Set (Set, empty)
---import qualified Data.Set as S
-
+import Data.Swagger (ToParamSchema)
+import Data.Swagger (ToSchema(..), genericDeclareNamedSchema)
 import Data.Text (Text, unpack)
 import Data.Validity
-
+import GHC.Generics
 import Gargantext.Core.Types.Main
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Types.Node
 import Gargantext.Prelude
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
-import GHC.Generics
 ------------------------------------------------------------------------
-
 type Name = Text
 type Term  = Text
 type Stems = Set Text
@@ -135,3 +140,28 @@ assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
 assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
 -- assertValid :: MonadIO m => Validation -> m ()
 -- assertValid v = when (not $ validationIsValid v) $ fail $ show v
+
+
+data TableResult a = TableResult { tr_count :: Int
+                                 , tr_docs :: [a]
+                                 } deriving (Generic)
+
+$(deriveJSON (unPrefix "tr_") ''TableResult)
+
+instance ToSchema a => ToSchema (TableResult a) where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "tr_")
+
+instance Arbitrary a => Arbitrary (TableResult a) where
+  arbitrary = TableResult <$> arbitrary <*> arbitrary
+
+type NodeTableResult a = TableResult (Node a)
+
+-- TO BE removed
+data TODO = TODO
+  deriving (Generic)
+
+instance ToSchema TODO where
+instance ToParamSchema TODO where
+
+
+

src/Gargantext/Core/Types/Main.hs

@@ -22,8 +22,7 @@ module Gargantext.Core.Types.Main where
 ------------------------------------------------------------------------
 
 import Prelude (Enum, Bounded, minBound, maxBound)
-import Data.Aeson (FromJSON, ToJSON, toJSON)
-import Data.Aeson as A
+import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson.TH (deriveJSON)
 import Data.Map (fromList, lookup)
 import Data.Either (Either(..))
@@ -33,7 +32,7 @@ import Data.Text (Text, unpack)
 import Data.Swagger
 
 import Gargantext.Database.Types.Node  -- (NodeType(..), Node, Hyperdata(..))
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Prelude
 
 import GHC.Generics (Generic)
@@ -49,38 +48,10 @@ data NodeTree = NodeTree { _nt_name :: Text
                          } deriving (Show, Read, Generic)
 
 $(deriveJSON (unPrefix "_nt_") ''NodeTree)
+instance ToSchema NodeTree where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nt_")
 ------------------------------------------------------------------------
 
--- Garg Network is a network of all Garg nodes
---gargNetwork = undefined
-
--- | Garg Node is Database Schema Typed as specification
--- gargNode gathers all the Nodes of all users on one Node
-gargNode :: [Tree NodeTree]
-gargNode = [userTree]
-
--- | User Tree simplified
-userTree :: Tree NodeTree
-userTree = TreeN (NodeTree "user name" NodeUser 1) [annuaireTree, projectTree]
-
--- | Project Tree
-projectTree :: Tree NodeTree
-projectTree = TreeN (NodeTree "Project CNRS/IMT" NodeFolder 2) [corpusTree 10 "A", corpusTree 20 "B"]
-
--- | Corpus Tree
-annuaireTree :: Tree NodeTree
-annuaireTree = (leafT $ NodeTree "Annuaire" NodeAnnuaire 41)
-
-corpusTree :: NodeId -> Text -> Tree NodeTree
-corpusTree nId t  = TreeN (NodeTree ("Corpus " <> t)  NodeCorpus nId) (  [ leafT $ NodeTree "Dashboard" NodeDashboard (nId +1)
-                                                                         , leafT $ NodeTree "Graph" NodeGraph (nId +2)
-                                                                         ]
---                                                      <> [ leafT $ NodeTree "My lists"  Lists    5]
---                          <> [ leafT (NodeTree "Metrics A" Metrics 6)  ]
---                          <> [ leafT (NodeTree "Class A" Classification 7)]
-                          )
-
-
 --data Classification = Favorites | MyClassifcation
 
 type HashId   = Text
@@ -127,17 +98,14 @@ type IsTrash  = Bool
 
 ------------------------------------------------------------------------
 -- All the Database is structred like a hierarchical Tree
-data Tree a = TreeN a [Tree a]
+data Tree a = TreeN { _tn_node :: a, _tn_children :: [Tree a] }
   deriving (Show, Read, Eq, Generic, Ord)
 
-instance ToJSON a => ToJSON   (Tree a) where
-  toJSON (TreeN node nodes) =
-    object ["node" A..= toJSON node, "children" A..= toJSON nodes]
+$(deriveJSON (unPrefix "_tn_") ''Tree)
 
-instance FromJSON a => FromJSON (Tree a)
+instance ToSchema a => ToSchema (Tree a) where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_tn_")
 
-instance ToSchema NodeTree
-instance ToSchema a => ToSchema  (Tree a)
 instance Arbitrary (Tree NodeTree) where
   arbitrary = elements [userTree, userTree]
 
@@ -146,3 +114,33 @@ instance Arbitrary (Tree NodeTree) where
 -- same as Data.Tree
 leafT :: a -> Tree a
 leafT x = TreeN x []
+
+------------------------------------------------------------------------
+-- Garg Network is a network of all Garg nodes
+--gargNetwork = undefined
+
+-- | Garg Node is Database Schema Typed as specification
+-- gargNode gathers all the Nodes of all users on one Node
+gargNode :: [Tree NodeTree]
+gargNode = [userTree]
+
+-- | User Tree simplified
+userTree :: Tree NodeTree
+userTree = TreeN (NodeTree "user name" NodeUser 1) [annuaireTree, projectTree]
+
+-- | Project Tree
+projectTree :: Tree NodeTree
+projectTree = TreeN (NodeTree "Project CNRS/IMT" NodeFolder 2) [corpusTree 10 "A", corpusTree 20 "B"]
+
+-- | Corpus Tree
+annuaireTree :: Tree NodeTree
+annuaireTree = (leafT $ NodeTree "Annuaire" NodeAnnuaire 41)
+
+corpusTree :: NodeId -> Text -> Tree NodeTree
+corpusTree nId t  = TreeN (NodeTree ("Corpus " <> t)  NodeCorpus nId) (  [ leafT $ NodeTree "Dashboard" NodeDashboard (nId +1)
+                                                                         , leafT $ NodeTree "Graph" NodeGraph (nId +2)
+                                                                         ]
+--                                                      <> [ leafT $ NodeTree "My lists"  Lists    5]
+--                          <> [ leafT (NodeTree "Metrics A" Metrics 6)  ]
+--                          <> [ leafT (NodeTree "Class A" Classification 7)]
+                          )

src/Gargantext/Core/Types/Phylo.hs

@@ -25,15 +25,18 @@ Phylomemy was first described in Chavalarias, D., Cointet, J.-P., 2013. Phylomem
 
 module Gargantext.Core.Types.Phylo where
 
+import Control.Lens (makeLenses)
+
 import Data.Aeson.TH (deriveJSON)
 import Data.Maybe   (Maybe)
+import Data.Swagger
 import Data.Text    (Text)
 import Data.Time.Clock.POSIX  (POSIXTime)
 
 import GHC.Generics (Generic)
 
 import Gargantext.Prelude
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 
 ------------------------------------------------------------------------
 -- | Phylo datatype descriptor of a phylomemy
@@ -94,8 +97,24 @@ type PhyloGroupId = (PhyloLevelId, Int)
 type Edge         = (PhyloGroupId, Weight)
 type Weight       = Double
 
+-- | Lenses
+makeLenses ''Phylo
+makeLenses ''PhyloPeriod
+makeLenses ''PhyloLevel
+makeLenses ''PhyloGroup
+
 -- | JSON instances
 $(deriveJSON (unPrefix "_phylo_"       ) ''Phylo       )
 $(deriveJSON (unPrefix "_phylo_Period" ) ''PhyloPeriod )
 $(deriveJSON (unPrefix "_phylo_Level"  ) ''PhyloLevel  )
 $(deriveJSON (unPrefix "_phylo_Group"  ) ''PhyloGroup  )
+
+-- | ToSchema instances
+instance ToSchema Phylo where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
+instance ToSchema PhyloPeriod where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_Period")
+instance ToSchema PhyloLevel where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_Level")
+instance ToSchema PhyloGroup where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_Group")

src/Gargantext/Core/Utils/Prefix.hs

@@ -22,6 +22,7 @@ import Data.Aeson.TH (Options, fieldLabelModifier, omitNothingFields)
 import Data.Aeson.Types (Parser)
 import Data.Char (toLower)
 import Data.Monoid ((<>))
+import Data.Swagger.SchemaOptions (SchemaOptions, fromAesonOptions)
 import Text.Read (Read(..),readMaybe)
 
 
@@ -32,6 +33,9 @@ unPrefix prefix = defaultOptions
   , omitNothingFields = True
   }
 
+unPrefixSwagger :: String -> SchemaOptions
+unPrefixSwagger = fromAesonOptions . unPrefix
+
 -- | Lower case leading character
 unCapitalize :: String -> String
 unCapitalize [] = []

src/Gargantext/Database.hs

@@ -17,9 +17,9 @@ Gargantext's database.
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module Gargantext.Database ( module Gargantext.Database.Utils
-                           , module Gargantext.Database.Bashql
+                        -- , module Gargantext.Database.Bashql
                            )
     where
 
 import Gargantext.Database.Utils (connectGargandb)
-import Gargantext.Database.Bashql
+-- import Gargantext.Database.Bashql

src/Gargantext/Database/Access.hs

@@ -7,6 +7,7 @@ Maintainer  : team@gargantext.org
 Stability   : experimental
 Portability : POSIX
 
+TODO-SECURITY review purpose of this module
 -}
 
 {-# LANGUAGE NoImplicitPrelude #-}

src/Gargantext/Database/Bashql.hs

+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 {-|
 Module      : Gargantext.Database.Bashql
 Description : BASHQL to deal with Gargantext Database.
@@ -55,13 +56,15 @@ AMS, and by SIAM.
 
 [3] https://github.com/Gabriel439/Haskell-Turtle-Library
 
+TODO-ACCESS: should the checks be done here or before.
+
 -}
 
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE RankNTypes        #-}
 
-module Gargantext.Database.Bashql ( get
+module Gargantext.Database.Bashql () {-( get
                                   , ls
                                   , home
                                   , post
@@ -71,7 +74,7 @@ module Gargantext.Database.Bashql ( get
                                   , rename
                                   , tree
                                   -- , mkCorpus, mkAnnuaire
-                                 )
+                                 )-}
     where
 
 import Control.Monad.Reader -- (Reader, ask)

src/Gargantext/Database/Config.hs

@@ -43,6 +43,10 @@ nodeTypeId n =
   case n of
     NodeUser      -> 1
     NodeFolder    -> 2
+    NodeFolderPrivate -> 20
+    NodeFolderShared  -> 21
+    NodeTeam          -> 210
+    NodeFolderPublic  -> 22
     NodeCorpusV3  -> 3
     NodeCorpus    -> 30
     NodeAnnuaire  -> 31
@@ -53,14 +57,15 @@ nodeTypeId n =
 
 ----  Lists
     NodeList      -> 5
-    NodeListModel -> 10
+    NodeListCooc  -> 50
+    NodeListModel -> 52
 
 ----  Scores
 --    NodeOccurrences -> 10
     NodeGraph       -> 9
     NodePhylo       -> 90
-    NodeDashboard   -> 7
-    NodeChart       -> 51
+    NodeChart       -> 7
+    NodeDashboard   -> 71
     NodeNoteBook    -> 88
 
 --  Cooccurrences -> 9
@@ -90,4 +95,5 @@ nodeTypes = [ (n, nodeTypeId n) | n <- allNodeTypes ]
 
 fromNodeTypeId :: NodeTypeId -> NodeType
 fromNodeTypeId tId = fromMaybe (panic $ pack $ "Type Id " <> show tId <> " does not exist")
-                            (lookup tId nodeTypeInv)
+                               (lookup tId nodeTypeInv)
+

src/Gargantext/Database/Facet.hs

@@ -26,10 +26,23 @@ Portability : POSIX
 {-# LANGUAGE TypeFamilies              #-}
 ------------------------------------------------------------------------
 module Gargantext.Database.Facet
+  ( runViewAuthorsDoc
+  , runViewDocuments
+  , filterWith
+
+  , Pair(..)
+  , Facet(..)
+  , FacetDoc
+  , FacetDocRead
+  , FacetPaired(..)
+  , FacetPairedRead
+  , OrderBy(..)
+  )
   where
 ------------------------------------------------------------------------
 import Control.Arrow (returnA)
-import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Control.Lens ((^.))
+-- import Control.Lens.TH (makeLensesWith, abbreviatedFields)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson.TH (deriveJSON)
 import Data.Either(Either(Left))
@@ -41,15 +54,16 @@ import Data.Time (UTCTime)
 import Data.Time.Segment (jour)
 import GHC.Generics (Generic)
 import Gargantext.Core.Types
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Config (nodeTypeId)
-import Gargantext.Database.Schema.Ngrams
 import Gargantext.Database.Schema.Node
-import Gargantext.Database.Schema.NodeNgram
+import Gargantext.Database.Schema.Ngrams
 import Gargantext.Database.Schema.NodeNode
+import Gargantext.Database.Schema.NodeNodeNgrams
+-- import Gargantext.Database.Schema.NodeNodeNgrams2
 import Gargantext.Database.Utils
-import Gargantext.Database.Queries.Join
 import Gargantext.Database.Queries.Filter
+import Gargantext.Database.Queries.Join (leftJoin5)
 import Opaleye
 import Prelude hiding (null, id, map, sum, not, read)
 import Servant.API
@@ -70,9 +84,9 @@ type Title    = Text
 
 -- TODO remove Title
 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Favorite) (Maybe Double)
-type FacetSources = FacetDoc
-type FacetAuthors = FacetDoc
-type FacetTerms   = FacetDoc
+-- type FacetSources = FacetDoc
+-- type FacetAuthors = FacetDoc
+-- type FacetTerms   = FacetDoc
 
 
 data Facet id created title hyperdata favorite ngramCount = 
@@ -99,50 +113,50 @@ $(deriveJSON (unPrefix "_p_") ''Pair)
 $(makeAdaptorAndInstance "pPair" ''Pair)
 
 instance (ToSchema i, ToSchema l) => ToSchema (Pair i l) where
-  declareNamedSchema =
-    genericDeclareNamedSchema
-      defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 3 fieldLabel}
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_p_")
 instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
   arbitrary = Pair <$> arbitrary <*> arbitrary
 
-data FacetPaired id date hyperdata score pairs =
+data FacetPaired id date hyperdata score pair =
   FacetPaired {_fp_id        :: id
               ,_fp_date      :: date
               ,_fp_hyperdata :: hyperdata
               ,_fp_score     :: score
-              ,_fp_pairs     :: pairs
+              ,_fp_pair      :: pair
   } deriving (Show, Generic)
 $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
 $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
 
-instance (ToSchema id, ToSchema date, ToSchema hyperdata, ToSchema pairs, ToSchema score) => ToSchema (FacetPaired id date hyperdata score pairs) where
-  declareNamedSchema =
-    genericDeclareNamedSchema
-      defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
+instance ( ToSchema id
+         , ToSchema date
+         , ToSchema hyperdata
+         , ToSchema score
+         , ToSchema pair
+         ) => ToSchema (FacetPaired id date hyperdata score pair) where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fp_")
 
 instance ( Arbitrary id
          , Arbitrary date
          , Arbitrary hyperdata
          , Arbitrary score
-         , Arbitrary pairs
-         ) => Arbitrary (FacetPaired id date hyperdata score pairs) where
+         , Arbitrary pair
+         ) => Arbitrary (FacetPaired id date hyperdata score pair) where
   arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 
---{-
 type FacetPairedRead = FacetPaired (Column PGInt4       )
                                    (Column PGTimestamptz)
                                    (Column PGJsonb      )
                                    (Column PGInt4       )
-                                   (Pair (Column (Nullable PGInt4)) (Column (Nullable PGText)))
---}
-
-
+                                   ( Column (Nullable PGInt4)
+                                   , Column (Nullable PGText)
+                                   )
 
 -- | JSON instance
 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
 
 -- | Documentation instance
-instance ToSchema FacetDoc
+instance ToSchema FacetDoc where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
 
 -- | Mock and Quickcheck instances
 instance Arbitrary FacetDoc where
@@ -158,7 +172,7 @@ instance Arbitrary FacetDoc where
 -- Facets / Views for the Front End
 -- | Database instances
 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
-$(makeLensesWith abbreviatedFields   ''Facet)
+-- $(makeLensesWith abbreviatedFields   ''Facet)
 
 type FacetDocRead = Facet (Column PGInt4       )
                           (Column PGTimestamptz)
@@ -196,6 +210,9 @@ instance Arbitrary OrderBy
     arbitrary = elements [minBound..maxBound]
 
 
+-- TODO-SECURITY check
+
+--{-
 runViewAuthorsDoc :: ContactId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
   where
@@ -214,28 +231,34 @@ viewAuthorsDoc cId _ nt = proc () -> do
   restrict -< _node_id   contact   .== (toNullable $ pgNodeId cId)
   restrict -< _node_typename doc   .== (pgInt4 $ nodeTypeId nt)
 
-  returnA  -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (toNullable $ pgInt4 1) (toNullable $ pgDouble 1)
+  returnA  -< FacetDoc (_node_id        doc)
+                       (_node_date      doc)
+                       (_node_name      doc)
+                       (_node_hyperdata doc)
+                       (toNullable $ pgInt4 1)
+                       (toNullable $ pgDouble 1)
 
-queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
-queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
+queryAuthorsDoc :: Query (NodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))
+queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNodeNgramsTable queryNgramsTable queryNodeNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
     where
-         cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
+         cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
          cond12 (nodeNgram, doc) =  _node_id                  doc
-                                .== nng_node_id nodeNgram
+                                .== _nnng_node1_id nodeNgram
+
+         cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
+         cond23 (ngrams, (nodeNgram, _)) =  ngrams^.ngrams_id
+                                        .== _nnng_ngrams_id nodeNgram
 
-         cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
-         cond23 (ngrams, (nodeNgram, _)) =  ngrams_id                  ngrams
-                                        .== nng_ngrams_id nodeNgram
-         
-         cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
-         cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams     .== nng_ngrams_id       nodeNgram2
-         
-         cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
-         cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== nng_node_id         nodeNgram2
+         cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column PGBool
+         cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams^.ngrams_id .== _nnng_ngrams_id       nodeNgram2
 
+         cond45 :: (NodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column PGBool
+         cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== _nnng_node1_id         nodeNgram2
 
+--}
 ------------------------------------------------------------------------
 
+-- TODO-SECURITY check
 runViewDocuments :: CorpusId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
 runViewDocuments cId t o l order =
     runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
@@ -246,13 +269,17 @@ viewDocuments :: CorpusId -> IsTrash -> NodeTypeId -> Query FacetDocRead
 viewDocuments cId t ntId = proc () -> do
   n  <- queryNodeTable     -< ()
   nn <- queryNodeNodeTable -< ()
-  restrict -< _node_id        n .== nn_node2_id nn
-  restrict -< nn_node1_id    nn .== (pgNodeId cId)
-  restrict -< _node_typename  n .== (pgInt4 ntId)
-  restrict -< if t then nn_category  nn .== (pgInt4 0)
-                   else nn_category  nn .>= (pgInt4 1)
-  returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (toNullable $ nn_category nn) (toNullable $ nn_score nn)
-
+  restrict -< n^.node_id       .== nn^.nn_node2_id
+  restrict -< nn^.nn_node1_id  .== (pgNodeId cId)
+  restrict -< n^.node_typename .== (pgInt4 ntId)
+  restrict -< if t then nn^.nn_category .== (pgInt4 0)
+                   else nn^.nn_category .>= (pgInt4 1)
+  returnA  -< FacetDoc (_node_id        n)
+                       (_node_date      n)
+                       (_node_name      n)
+                       (_node_hyperdata n)
+                       (toNullable $ nn^.nn_category)
+                       (toNullable $ nn^.nn_score)
 
 ------------------------------------------------------------------------
 filterWith :: (PGOrd date, PGOrd title, PGOrd score, hyperdata ~ Column SqlJsonb) =>

src/Gargantext/Database/Flow/List.hs

+{-|
+Module      : Gargantext.Database.Flow.List
+Description : List Flow
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# OPTIONS_GHC -fno-warn-orphans    #-}
+
+{-# LANGUAGE ConstraintKinds         #-}
+{-# LANGUAGE RankNTypes              #-}
+{-# LANGUAGE ConstrainedClassMethods #-}
+{-# LANGUAGE ConstraintKinds         #-}
+{-# LANGUAGE DeriveGeneric           #-}
+{-# LANGUAGE FlexibleContexts        #-}
+{-# LANGUAGE InstanceSigs            #-}
+{-# LANGUAGE NoImplicitPrelude       #-}
+{-# LANGUAGE OverloadedStrings       #-}
+
+module Gargantext.Database.Flow.List
+    where
+import Data.Text (Text)
+import Control.Monad (mapM_)
+import Data.Map (Map, toList)
+import Data.Maybe (Maybe(..), catMaybes)
+import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams)
+import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams,  NgramsType(..), text2ngrams, ngramsTypeId)
+import Gargantext.Core.Types.Main (ListType(CandidateTerm))
+import Gargantext.Database.Schema.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
+import Gargantext.Database.Schema.Node_NodeNgramsNodeNgrams -- (insert_Node_NodeNgrams_NodeNgrams, Node_NodeNgrams_NodeNgrams(..))
+import Gargantext.Database.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
+import Gargantext.Database.Flow.Types
+import Gargantext.Prelude
+import qualified Data.List as List
+import qualified Data.Map  as Map
+
+
+-- FLOW LIST
+-- | TODO check optimization
+mapNodeIdNgrams :: [DocumentIdWithNgrams a]
+                -> Map Ngrams (Map NgramsType (Map NodeId Int))
+mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
+  where
+    f :: DocumentIdWithNgrams a
+      -> Map Ngrams (Map NgramsType (Map NodeId Int))
+    f d = fmap (fmap (Map.singleton nId)) $ document_ngrams d
+      where
+        nId = documentId $ documentWithId d
+
+------------------------------------------------------------------------
+flowList_DbRepo :: FlowCmdM env err m
+         => ListId
+         -> Map NgramsType [NgramsElement]
+         -> m ListId
+flowList_DbRepo lId ngs = do
+  -- printDebug "listId flowList" lId
+  mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
+  let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> parent)
+                                 <*>  getCgramsId mapCgramsId ntype ngram
+                           | (ntype, ngs') <- Map.toList ngs
+                           , NgramsElement ngram _ _ _ _ parent _ <- ngs'
+                           ]
+  -- Inserting groups of ngrams
+  _r <- insert_Node_NodeNgrams_NodeNgrams
+     $ map (\(a,b) -> Node_NodeNgrams_NodeNgrams lId a b Nothing) toInsert
+  listInsert lId ngs
+  --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
+  pure lId
+------------------------------------------------------------------------
+------------------------------------------------------------------------
+
+toNodeNgramsW :: ListId
+              -> [(NgramsType, [NgramsElement])]
+              -> [NodeNgramsW]
+toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
+  where
+    toNodeNgramsW'' :: ListId
+                  -> (NgramsType, [NgramsElement])
+                  -> [NodeNgramsW]
+    toNodeNgramsW'' l' (ngrams_type, elms) =
+      [ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
+       (NgramsElement ngrams_terms' _size list_type _occ _root _parent _children) <- elms
+      ]
+
+toNodeNgramsW' :: ListId
+               -> [(Text, [NgramsType])]
+               -> [NodeNgramsW]
+toNodeNgramsW' l'' ngs = [ NodeNgrams Nothing l'' CandidateTerm terms ngrams_type Nothing Nothing Nothing 0
+                         | (terms, ngrams_types) <- ngs
+                         , ngrams_type <- ngrams_types
+                         ]
+
+
+listInsert :: FlowCmdM env err m
+             => ListId
+             -> Map NgramsType [NgramsElement]
+             -> m ()
+listInsert lId ngs = mapM_ (\(typeList, ngElmts)
+                             -> putListNgrams lId typeList ngElmts
+                             ) $ toList ngs
+------------------------------------------------------------------------
+------------------------------------------------------------------------
+

src/Gargantext/Database/Flow/Pairing.hs

@@ -16,10 +16,11 @@ Portability : POSIX
 -- {-# LANGUAGE Arrows #-}
 
 module Gargantext.Database.Flow.Pairing
+  (pairing)
     where
 
 --import Debug.Trace (trace)
-import Control.Lens (_Just,view)
+import Control.Lens (_Just, (^.))
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 -- import Opaleye
 -- import Opaleye.Aggregate
@@ -31,55 +32,69 @@ import qualified Data.Map as DM
 import Data.Text (Text, toLower)
 import qualified Data.Text as DT
 import Gargantext.Prelude hiding (sum)
+import Gargantext.Core.Types (TableResult(..))
 import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
---import Gargantext.Database.Node.Contact -- (HyperdataContact(..))
---import Gargantext.Database.Types.Node -- (Hyperdata(..))
-import Gargantext.Database.Node.Contact
+import Gargantext.Database.Node.Contact -- (HyperdataContact(..))
 import Gargantext.Database.Flow.Utils
 import Gargantext.Database.Utils (Cmd, runPGSQuery)
-import Gargantext.Database.Types.Node (AnnuaireId, CorpusId)
-import Gargantext.Database.Node.Children
-import Gargantext.Core.Types (NodeType(..))
+import Gargantext.Database.Types.Node (AnnuaireId, CorpusId, ListId{-, DocId, ContactId-})
+import Gargantext.Database.Node.Children (getAllContacts)
 
 -- TODO mv this type in Types Main
 type Terms = Text
 
+{-
+pairing'' :: (CorpusId, CorpusId) -> (DocId -> DocId)
+pairing'' = undefined
+
+pairing' :: (CorpusId, AnnuaireId) -> (DocId -> ContactId)
+pairing' = undefined
+-}
+
 -- | TODO : add paring policy as parameter
-pairing :: AnnuaireId -> CorpusId -> Cmd err Int
-pairing aId cId = do
-  contacts' <- getContacts aId (Just NodeContact)
-  let contactsMap = pairingPolicyToMap toLower $ toMaps extractNgramsT contacts'
+pairing :: CorpusId   -- (CorpusId,   ListId) -- Pair (Either CorpusId AnnuaireId) ListId
+        -> AnnuaireId -- (AnnuaireId, ListId) -- Pair (Either CorpusId AnnuaireId) ListId
+        -> ListId
+        -> Cmd err Int
+pairing cId aId lId = do
+  contacts' <- getAllContacts aId
+  let contactsMap = pairingPolicyToMap toLower
+                  $ toMaps extractNgramsT (tr_docs contacts')
 
   ngramsMap' <- getNgramsTindexed cId Authors
   let ngramsMap = pairingPolicyToMap lastName ngramsMap'
 
   let indexedNgrams = pairMaps contactsMap ngramsMap
 
-  insertToNodeNgrams indexedNgrams
-  -- TODO add List
+  insertDocNgrams lId indexedNgrams
 
 lastName :: Terms -> Terms
-lastName texte = DT.toLower $ maybe texte (\x -> if DT.length x > 3 then x else texte) (lastName' texte)
+lastName texte = DT.toLower
+               $ maybe texte (\x -> if DT.length x > 3 then x else texte) (lastName' texte)
   where
     lastName' = lastMay . DT.splitOn " "
 
--- TODO: this methods is dangerous (maybe equalities of the result are not taken into account
--- emergency demo plan...
+-- TODO: this method is dangerous (maybe equalities of the result are not taken into account
+-- emergency demo plan...)
 pairingPolicyToMap :: (Terms -> Terms)
-                    -> Map (NgramsT Ngrams) a -> Map (NgramsT Ngrams) a
+                   -> Map (NgramsT Ngrams) a
+                   -> Map (NgramsT Ngrams) a
 pairingPolicyToMap f = DM.mapKeys (pairingPolicy f)
 
-pairingPolicy :: (Terms -> Terms) -> NgramsT Ngrams -> NgramsT Ngrams
+pairingPolicy :: (Terms -> Terms)
+              -> NgramsT Ngrams
+              -> NgramsT Ngrams
 pairingPolicy f (NgramsT nt (Ngrams ng _)) = (NgramsT nt (Ngrams (f ng) 1))
 
 -- | TODO : use Occurrences in place of Int
-extractNgramsT :: HyperdataContact -> Map (NgramsT Ngrams) Int
+extractNgramsT :: HyperdataContact
+               -> Map (NgramsT Ngrams) Int
 extractNgramsT contact = fromList [(NgramsT Authors    a' , 1)| a' <- authors    ]
   where
-    authors    = map text2ngrams $ catMaybes [view (hc_who . _Just . cw_lastName) contact]
---}
+    authors    = map text2ngrams
+               $ catMaybes [ contact^.(hc_who . _Just . cw_lastName) ]
+
 
--- NP: notice how this function is no longer specific to the ContactId type
 pairMaps :: Map (NgramsT Ngrams) a
          -> Map (NgramsT Ngrams) NgramsId
          -> Map NgramsIndexed (Map NgramsType a)
@@ -91,23 +106,28 @@ pairMaps m1 m2 =
     ]
 
 -----------------------------------------------------------------------
-getNgramsTindexed:: CorpusId -> NgramsType -> Cmd err (Map (NgramsT Ngrams) NgramsId)
+getNgramsTindexed :: CorpusId
+                  -> NgramsType
+                  -> Cmd err (Map (NgramsT Ngrams) NgramsId)
 getNgramsTindexed corpusId ngramsType' = fromList
     <$> map (\(ngramsId',t,n) -> (NgramsT ngramsType' (Ngrams t n),ngramsId'))
     <$> selectNgramsTindexed corpusId ngramsType'
-
-selectNgramsTindexed :: CorpusId -> NgramsType -> Cmd err [(NgramsId, Terms, Int)]
-selectNgramsTindexed corpusId ngramsType'' = runPGSQuery selectQuery (corpusId, ngramsTypeId ngramsType'')
   where
-    selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
-                  JOIN nodes_ngrams occ ON occ.ngram_id = n.id
-                  JOIN nodes_nodes  nn  ON nn.node2_id = occ.node_id
-                  
-                  WHERE nn.node1_id     = ?
-                    AND occ.ngrams_type = ?
-                    AND occ.node_id = nn.node2_id
-                  GROUP BY n.id;
-                 |]
+    selectNgramsTindexed :: CorpusId
+                         -> NgramsType
+                         -> Cmd err [(NgramsId, Terms, Int)]
+    selectNgramsTindexed corpusId' ngramsType'' = runPGSQuery selectQuery (corpusId', ngramsTypeId ngramsType'')
+      where
+        selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
+                      JOIN node_node_ngrams occ ON occ.ngrams_id = n.id
+                      -- JOIN node_node_ngrams2 occ ON occ.ngrams_id = n.id
+                      JOIN nodes_nodes      nn  ON nn.node2_id   = occ.node2_id
+
+                      WHERE nn.node1_id     = ?
+                        AND occ.ngrams_type = ?
+                        AND occ.node2_id = nn.node2_id
+                      GROUP BY n.id;
+                     |]
 
 {- | TODO more typed SQL queries
 selectNgramsTindexed :: CorpusId -> NgramsType -> Query NgramsRead
@@ -123,5 +143,3 @@ selectNgramsTindexed corpusId ngramsType = proc () -> do
     result <- aggregate groupBy (ngrams_id ngrams)
     returnA -< result
 --}
-
-

src/Gargantext/Database/Flow/Types.hs

+{-|
+Module      : Gargantext.Database.Flow.Types
+Description : Types for Flow
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# OPTIONS_GHC -fno-warn-orphans    #-}
+
+{-# LANGUAGE ConstraintKinds         #-}
+{-# LANGUAGE RankNTypes              #-}
+{-# LANGUAGE ConstrainedClassMethods #-}
+{-# LANGUAGE ConstraintKinds         #-}
+{-# LANGUAGE DeriveGeneric           #-}
+{-# LANGUAGE FlexibleContexts        #-}
+{-# LANGUAGE InstanceSigs            #-}
+{-# LANGUAGE NoImplicitPrelude       #-}
+{-# LANGUAGE OverloadedStrings       #-}
+
+module Gargantext.Database.Flow.Types
+    where
+
+import Data.Map (Map)
+import Gargantext.Prelude
+import Gargantext.Core.Flow.Types
+import Gargantext.API.Ngrams (HasRepoVar, RepoCmdM)
+import Gargantext.Database.Schema.Ngrams (Ngrams(..), NgramsType(..))
+import Gargantext.Database.Types.Node (NodeId)
+import Gargantext.Database.Schema.Node (HasNodeError)
+import Gargantext.Database.Utils (CmdM)
+
+type FlowCmdM env err m =
+  ( CmdM     env err m
+  , RepoCmdM env err m
+  , HasNodeError err
+  , HasRepoVar env
+  )
+
+data DocumentIdWithNgrams a = DocumentIdWithNgrams
+  { documentWithId  :: !(DocumentWithId a)
+  , document_ngrams :: !(Map Ngrams (Map NgramsType Int))
+  } deriving (Show)
+
+data DocumentWithId a = DocumentWithId
+  { documentId   :: !NodeId
+  , documentData :: !a
+  } deriving (Show)
+
+instance HasText a => HasText (DocumentWithId a)
+  where
+    hasText (DocumentWithId _ a) = hasText a
+
+

src/Gargantext/Database/Init.hs

+{-|
+Module      : Gargantext.Database.Init
+Description : Triggers configuration
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Ngrams by node enable contextual metrics.
+
+-}
+
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
+
+module Gargantext.Database.Init
+  where
+
+-- import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
+import Gargantext.Database.Utils (Cmd)
+import Gargantext.Prelude
+import Gargantext.Database.Triggers.Nodes (triggerSearchUpdate)
+import Gargantext.Database.Triggers.NodesNodes (triggerDeleteCount, triggerInsertCount, triggerUpdateAdd, triggerUpdateDel, MasterListId) -- , triggerCoocInsert)
+import Gargantext.Database.Triggers.NodeNodeNgrams (triggerCountInsert, triggerCountInsert2)
+------------------------------------------------------------------------
+
+initTriggers :: MasterListId -> Cmd err [Int64]
+initTriggers lId = do
+  t0 <- triggerSearchUpdate
+  t1 <- triggerCountInsert
+  t1' <- triggerCountInsert2
+  -- t1'' <- triggerCoocInsert lId
+  t2 <- triggerDeleteCount lId
+  t3 <- triggerInsertCount lId
+  t4 <- triggerUpdateAdd   lId
+  t5 <- triggerUpdateDel   lId
+  pure [t0
+       ,t1
+       ,t1'
+       -- ,t1''
+       ,t2
+       ,t3
+       ,t4
+       ,t5]
+
+