[MERGE] Dev -> stable

.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
+
+
+
+

bin/gargantext-adaptative-phylo/Main.hs

@@ -26,7 +26,7 @@ import Data.ByteString.Lazy (ByteString)
 import Data.Maybe (isJust, fromJust)
 import Data.List  (concat, nub, isSuffixOf, take)
 import Data.String (String)
-import Data.Text  (Text, unwords)
+import Data.Text  (Text, unwords, unpack)
 
 import Gargantext.Prelude
 import Gargantext.Database.Types.Node (HyperdataDocument(..))
@@ -36,7 +36,10 @@ import Gargantext.Text.Corpus.Parsers (FileFormat(..),parseFile)
 import Gargantext.Text.List.CSV (csvGraphTermList)
 import Gargantext.Text.Terms.WithList (Patterns, buildPatterns, extractTermsWithList)
 import Gargantext.Viz.AdaptativePhylo
-import Gargantext.Viz.Phylo.PhyloMaker (toPhylo)
+import Gargantext.Viz.Phylo.PhyloMaker  (toPhylo)
+import Gargantext.Viz.Phylo.PhyloTools  (printIOMsg, printIOComment)
+import Gargantext.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
+-- import Gargantext.Viz.Phylo.SynchronicClustering (synchronicDistance')
 
 import GHC.IO (FilePath) 
 import Prelude (Either(..))
@@ -54,21 +57,6 @@ import qualified Gargantext.Text.Corpus.Parsers.CSV as Csv
 ---------------
 
 
--- | To print an important message as an IO()
-printIOMsg :: String -> IO ()
-printIOMsg msg = 
-    putStrLn ( "\n"
-            <> "------------" 
-            <> "\n"
-            <> "-- | " <> msg <> "\n" )
-
-
--- | To print a comment as an IO()
-printIOComment :: String -> IO ()
-printIOComment cmt =
-    putStrLn ( "\n" <> cmt <> "\n" )
-
-
 -- | To get all the files in a directory or just a file
 getFilesFromPath :: FilePath -> IO([FilePath])
 getFilesFromPath path = do 
@@ -166,6 +154,23 @@ main = do
             printIOComment (show (length corpus) <> " parsed docs from the corpus")
 
             printIOMsg "Reconstruct the Phylo"
+            
             let phylo = toPhylo corpus mapList config
 
-            printIOMsg "End of reconstruction"
+            -- | probes
\ No newline at end of file
+
+            -- writeFile ((outputPath config) <> (unpack $ phyloName config) <> "_synchronic_distance_cumu_jaccard.txt") 
+            --          $ synchronicDistance' phylo 1
+
+            -- writeFile ((outputPath config) <> (unpack $ phyloName config) <> "_inflexion_points.txt") 
+            --         $ inflexionPoints phylo 1                    
+
+            printIOMsg "End of reconstruction, start the export"
+
+            let dot = toPhyloExport phylo
+
+            let output = (outputPath config) 
+                      <> (unpack $ phyloName config)
+                      <> "_V2.dot"
+
+            dotToFile output dot
\ No newline at end of file

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,9 +41,10 @@ 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
   
@@ -51,8 +52,16 @@ main = do
     --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
+    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 CsvHalFormat 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

@@ -28,7 +28,7 @@ import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument, RootId)
 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(..))
@@ -42,7 +42,7 @@ main = do
 
   let createUsers :: Cmd GargError Int64
       createUsers = insertUsersDemo
-  
+
   let
     mkRoots :: Cmd GargError (UserId, RootId)
     mkRoots = getOrMkRoot "user1"

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-postgres

@@ -4,6 +4,6 @@ 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/postgres/create

 #!/bin/bash
 
-sudo su postgres
+# sudo su postgres
+
+# postgresql://$USER:$PW@localhost/$DB
 
 PW="password"
 DB="gargandbV5"
 USER="gargantua"
 
-psql -c "CREATE USER \"${USER}\"
+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}\""
 
 
 

devops/postgres/schema.sql

@@ -80,6 +80,7 @@ ALTER TABLE public.ngrams OWNER TO gargantua;
 --ALTER TABLE public.nodes_ngrams_ngrams OWNER TO gargantua;
 
 ---------------------------------------------------------------
+-- TODO nodes_nodes(node1_id int, node2_id int, edge_type int , weight real)
 CREATE TABLE public.nodes_nodes (
     node1_id integer NOT NULL REFERENCES public.nodes(id) ON DELETE CASCADE,
     node2_id integer NOT NULL REFERENCES public.nodes(id) ON DELETE CASCADE,
@@ -134,17 +135,20 @@ CREATE INDEX        ON public.rights USING btree (user_id,node_id);
 
 CREATE INDEX        ON public.nodes USING gin (hyperdata);
 CREATE INDEX        ON public.nodes USING btree (user_id, typename, parent_id);
+CREATE INDEX        ON public.nodes USING btree (typename, id);
 CREATE UNIQUE INDEX ON public.nodes USING btree (((hyperdata ->> 'uniqId'::text)));
 CREATE UNIQUE INDEX ON public.nodes USING btree (((hyperdata ->> 'uniqIdBdd'::text)));
 CREATE UNIQUE INDEX ON public.nodes USING btree (typename, parent_id, ((hyperdata ->> 'uniqId'::text)));
 
 CREATE UNIQUE INDEX ON public.ngrams (terms); -- TEST GIN
+CREATE        INDEX ON public.ngrams USING btree (id, terms);
 
 CREATE INDEX        ON public.nodes_nodes  USING btree (node1_id, node2_id, category);
 CREATE UNIQUE INDEX ON public.nodes_nodes  USING btree (node1_id, node2_id);
 
 CREATE UNIQUE INDEX ON public.node_node_ngrams USING btree (node1_id, node2_id, ngrams_id, ngrams_type);
-create INDEX on public.node_node_ngrams USING btree (node1_id, node2_id);
+CREATE        INDEX ON public.node_node_ngrams USING btree (node1_id,  node2_id);
+CREATE        INDEX ON public.node_node_ngrams USING btree (ngrams_id, node2_id);
 
 -- TRIGGERS
 -- TODO user haskell-postgresql-simple to create this function
@@ -154,10 +158,10 @@ RETURNS trigger AS $$
 begin
   IF new.typename = 4 AND new.hyperdata @> '{"language_iso2":"EN"}' THEN
     new.search := to_tsvector( 'english' , (new.hyperdata ->> 'title') || ' ' || (new.hyperdata ->> 'abstract'));
-  
+
   ELSIF new.typename = 4 AND new.hyperdata @> '{"language_iso2":"FR"}' THEN
     new.search := to_tsvector( 'french' , (new.hyperdata ->> 'title') || ' ' || (new.hyperdata ->> 'abstract'));
-  
+
   ELSIF new.typename = 41 THEN
     new.search := to_tsvector( 'french' , (new.hyperdata ->> 'prenom')
                                  || ' ' || (new.hyperdata ->> 'nom')
@@ -191,6 +195,3 @@ UPDATE nodes SET hyperdata = hyperdata;
 
 
 
-
-
-

package.yaml

@@ -33,6 +33,7 @@ library:
     #  - Gargantext.API.Orchestrator
   - Gargantext.API.Search
   - Gargantext.API.Settings
+  - Gargantext.API.Types
   - Gargantext.Core
   - Gargantext.Core.Types
   - Gargantext.Core.Types.Main
@@ -71,6 +72,9 @@ library:
   - Gargantext.Viz.AdaptativePhylo
   - Gargantext.Viz.Phylo.PhyloMaker
   - Gargantext.Viz.Phylo.Tools
+  - Gargantext.Viz.Phylo.PhyloTools
+  - Gargantext.Viz.Phylo.PhyloExport
+  - Gargantext.Viz.Phylo.SynchronicClustering
   - Gargantext.Viz.Phylo.Example
   - Gargantext.Viz.Phylo.LevelMaker
   - Gargantext.Viz.Phylo.View.Export
@@ -82,11 +86,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
@@ -94,6 +100,7 @@ library:
   - case-insensitive
   - cassava
   #- charsetdetect-ae  # detect charset
+  - clock
   - clustering-louvain
   - conduit
   - conduit-extra
@@ -109,6 +116,7 @@ library:
   - duckling
   - exceptions
   - filepath
+  - formatting
   - fullstop
   - fclabels
   - fgl
@@ -130,7 +138,7 @@ library:
   - hlcm
   - ini
   - insert-ordered-containers
-  - jose-jwt
+  - jose
     #  - kmeans-vector
   - json-stream
   - KMP
@@ -156,10 +164,13 @@ library:
   - profunctors
   - protolude
   - pureMD5
+  - random-shuffle
+  - MonadRandom
   - SHA
   - simple-reflect
   - cereal     # (IGraph)
   - singletons # (IGraph)
+  - quickcheck-instances
   - random
   - rake
   - regex-compat
@@ -169,9 +180,11 @@ library:
   - semigroups
   - servant
   - servant-auth
+  - servant-auth-server >= 0.4.4.0
+  - servant-auth-swagger
   - servant-blaze
   - servant-client
-    #  - servant-job
+  - servant-job
   - servant-mock
   - servant-multipart
   - servant-server

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,8 +18,8 @@ New corpus means either:
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE TypeOperators      #-}
 {-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE FlexibleContexts     #-}
-{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE RankNTypes         #-}
 
 module Gargantext.API.Corpus.New
       where
@@ -30,12 +30,14 @@ import Data.Aeson.TH (deriveJSON)
 import Data.Swagger
 import Data.Text (Text)
 import GHC.Generics (Generic)
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Flow (flowCorpusSearchInDatabase)
 import Gargantext.Database.Types.Node (CorpusId)
 import Gargantext.Text.Terms (TermType(..))
 import Gargantext.Prelude
+import Gargantext.API.Orchestrator.Types
 import Servant
+-- import Servant.Job.Server
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary
 import Gargantext.Core (Lang(..))
@@ -60,9 +62,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,6 +70,8 @@ type Api = Summary "New Corpus endpoint"
         :<|> Get '[JSON] ApiInfo
 
 -- | TODO manage several apis
+-- TODO-ACCESS
+-- TODO this is only the POST
 api :: (FlowCmdM env err m) => Query -> m CorpusId
 api (Query q _ as) = do
   cId <- case head as of
@@ -95,4 +97,58 @@ instance ToSchema ApiInfo
 info :: FlowCmdM env err m => UserId -> m ApiInfo
 info _u = pure $ ApiInfo API.externalAPIs
 
+{-
+-- Proposal to replace the Query type which seems to generically named.
+data ScraperInput = ScraperInput
+  { _scin_query     :: !Text
+  , _scin_corpus_id :: !Int
+  , _scin_databases :: [API.ExternalAPIs]
+  }
+  deriving (Eq, Show, Generic)
+
+makeLenses ''ScraperInput
+
+deriveJSON (unPrefix "_scin_") 'ScraperInput
+
+data ScraperEvent = ScraperEvent
+  { _scev_message :: !(Maybe Text)
+  , _scev_level   :: !(Maybe Text)
+  , _scev_date    :: !(Maybe Text)
+  }
+  deriving Generic
+
+deriveJSON (unPrefix "_scev_") 'ScraperEvent
+
+data ScraperStatus = ScraperStatus
+  { _scst_succeeded :: !(Maybe Int)
+  , _scst_failed    :: !(Maybe Int)
+  , _scst_remaining :: !(Maybe Int)
+  , _scst_events    :: !(Maybe [ScraperEvent])
+  }
+  deriving Generic
+
+deriveJSON (unPrefix "_scst_") 'ScraperStatus
+-}
 
+type API_v2 =
+  Summary "Add to corpus endpoint" :>
+  "corpus" :>
+  Capture "corpus_id" CorpusId :>
+  "add" :>
+  "async" :> ScraperAPI2
+
+  -- TODO ScraperInput2 also has a corpus id
+addToCorpusJobFunction :: FlowCmdM env err m => CorpusId -> ScraperInput2 -> (ScraperStatus -> m ()) -> m ScraperStatus
+addToCorpusJobFunction _cid _input 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 []
+                          }

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/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.hs

+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 {-|
 Module      : Gargantext.API.Ngrams
 Description : Server API
@@ -32,6 +33,61 @@ add get
 {-# OPTIONS -fno-warn-orphans #-}
 
 module Gargantext.API.Ngrams
+  ( TableNgramsApi
+  , TableNgramsApiGet
+  , TableNgramsApiPut
+  , TableNgramsApiPost
+
+  , getTableNgrams
+  , putListNgrams
+  , tableNgramsPost
+  , apiNgramsTableCorpus
+  , apiNgramsTableDoc
+
+  , NgramsStatePatch
+  , NgramsTablePatch
+
+  , NgramsElement
+  , mkNgramsElement
+  , mergeNgramsElement
+
+  , RootParent(..)
+
+  , MSet
+  , mSetFromList
+  , mSetToList
+
+  , Repo(..)
+  , r_version
+  , r_state
+  , NgramsRepo
+  , NgramsRepoElement(..)
+  , saveRepo
+  , initRepo
+
+  , RepoEnv(..)
+  , renv_var
+  , renv_lock
+
+  , TabType(..)
+  , ngramsTypeFromTabType
+
+  , HasRepoVar(..)
+  , HasRepoSaver(..)
+  , HasRepo(..)
+  , RepoCmdM
+  , QueryParamR
+  , TODO(..)
+
+  -- Internals
+  , getNgramsTableMap
+  , tableNgramsPull
+  , tableNgramsPut
+
+  , Versioned(..)
+  , currentVersion
+  , listNgramsChangedSince
+  )
   where
 
 -- import Debug.Trace (trace)
@@ -56,7 +112,7 @@ import Data.Map.Strict (Map)
 import qualified Data.Set as Set
 import Control.Category ((>>>))
 import Control.Concurrent
-import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, forOf_, (%%~), (?~))
+import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, forOf_, (%%~), (?~), mapped)
 import Control.Monad.Error.Class (MonadError)
 import Control.Monad.Reader
 import Control.Monad.State
@@ -68,11 +124,13 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import Data.Swagger hiding (version, patch)
 import Data.Text (Text, isInfixOf, count)
 import Data.Validity
+import Formatting (hprint, int, (%))
+import Formatting.Clock (timeSpecs)
 import GHC.Generics (Generic)
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 -- import Gargantext.Database.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
 import Gargantext.Database.Config (userMaster)
-import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlyFast)
+import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlyFast')
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Database.Types.Node (NodeType(..))
 import Gargantext.Database.Utils (fromField', HasConnection)
@@ -87,7 +145,9 @@ import Gargantext.Prelude
 -- import Gargantext.Core.Types (ListTypeId, listTypeId)
 import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, HasInvalidError, assertValid)
 import Servant hiding (Patch)
+import System.Clock (getTime, TimeSpec, Clock(..))
 import System.FileLock (FileLock)
+import System.IO (stderr)
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
@@ -208,7 +268,8 @@ mkNgramsElement ngrams list rp children =
 newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement
 newNgramsElement mayList ngrams = mkNgramsElement ngrams (fromMaybe GraphTerm mayList) Nothing mempty
 
-instance ToSchema NgramsElement
+instance ToSchema NgramsElement where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
 instance Arbitrary NgramsElement where
   arbitrary = elements [newNgramsElement Nothing "sport"]
 
@@ -462,7 +523,8 @@ data NgramsPatch =
 deriveJSON (unPrefix "_") ''NgramsPatch
 makeLenses ''NgramsPatch
 
-instance ToSchema  NgramsPatch
+instance ToSchema  NgramsPatch where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
 
 instance Arbitrary NgramsPatch where
   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
@@ -597,7 +659,8 @@ data Versioned a = Versioned
   deriving (Generic, Show)
 deriveJSON (unPrefix "_v_") ''Versioned
 makeLenses ''Versioned
-instance ToSchema a => ToSchema (Versioned a)
+instance ToSchema a => ToSchema (Versioned a) where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_v_")
 instance Arbitrary a => Arbitrary (Versioned a) where
   arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 
@@ -798,12 +861,34 @@ putListNgrams listId ngramsType nes = do
   where
     m = Map.fromList $ (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) <$> nes
 
+-- TODO-ACCESS check
 tableNgramsPost :: RepoCmdM env err m => TabType -> NodeId -> Maybe ListType -> [NgramsTerm] -> m ()
 tableNgramsPost tabType listId mayList =
   putListNgrams listId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
 
+currentVersion :: RepoCmdM env err m => m Version
+currentVersion = do
+  var <- view repoVar
+  r <- liftIO $ readMVar var
+  pure $ r ^. r_version
+
+tableNgramsPull :: RepoCmdM env err m
+                => ListId -> NgramsType
+                -> Version
+                -> m (Versioned NgramsTablePatch)
+tableNgramsPull listId ngramsType p_version = do
+  var <- view repoVar
+  r <- liftIO $ readMVar var
+
+  let
+    q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
+    q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
+
+  pure (Versioned (r ^. r_version) q_table)
+
 -- Apply the given patch to the DB and returns the patch to be applied on the
 -- client.
+-- TODO-ACCESS check
 tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
                  => TabType -> ListId
                  -> Versioned NgramsTablePatch
@@ -811,15 +896,7 @@ tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
 tableNgramsPut tabType listId (Versioned p_version p_table)
   | p_table == mempty = do
       let ngramsType        = ngramsTypeFromTabType tabType
-
-      var <- view repoVar
-      r <- liftIO $ readMVar var
-
-      let
-        q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
-        q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
-
-      pure (Versioned (r ^. r_version) q_table)
+      tableNgramsPull listId ngramsType p_version
 
   | otherwise         = do
       let ngramsType        = ngramsTypeFromTabType tabType
@@ -880,7 +957,8 @@ type MaxSize = Int
 -- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
 -- TODO: should take only one ListId
 
-
+getTime' :: MonadIO m => m TimeSpec
+getTime' = liftIO $ getTime ProcessCPUTime
 
 
 getTableNgrams :: forall env err m.
@@ -895,7 +973,8 @@ getTableNgrams :: forall env err m.
 getTableNgrams _nType nId tabType listId limit_ offset
                listType minSize maxSize orderBy searchQuery = do
 
-  _lIds <- selectNodesWithUsername NodeList userMaster
+  t0 <- getTime'
+  -- lIds <- selectNodesWithUsername NodeList userMaster
   let
     ngramsType = ngramsTypeFromTabType tabType
     offset'  = maybe 0 identity offset
@@ -939,15 +1018,21 @@ getTableNgrams _nType nId tabType listId limit_ offset
     setScores False table = pure table
     setScores True  table = do
       let ngrams_terms = (table ^.. each . ne_ngrams)
-      occurrences <- getOccByNgramsOnlyFast nId
+      t1 <- getTime'
+      occurrences <- getOccByNgramsOnlyFast' nId
+                                             listId
                                             ngramsType
                                             ngrams_terms
+      t2 <- getTime'
+      liftIO $ hprint stderr
+        ("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
+        (length ngrams_terms) t1 t2
       {-
       occurrences <- getOccByNgramsOnlySlow nType nId
                                             (lIds <> [listId])
                                             ngramsType
                                             ngrams_terms
-    -}
+      -}
       let
         setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
 
@@ -960,11 +1045,24 @@ getTableNgrams _nType nId tabType listId limit_ offset
 
   let nSco = needsScores orderBy
   tableMap1 <- getNgramsTableMap listId ngramsType
+  t1 <- getTime'
   tableMap2 <- tableMap1 & v_data %%~ setScores nSco
                                     . Map.mapWithKey ngramsElementFromRepo
-  tableMap2 & v_data %%~ fmap NgramsTable
-                       . setScores (not nSco)
-                       . selectAndPaginate
+  t2 <- getTime'
+  tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
+                                    . setScores (not nSco)
+                                    . selectAndPaginate
+  t3 <- getTime'
+  liftIO $ hprint stderr
+            ("getTableNgrams total=" % timeSpecs
+                          % " map1=" % timeSpecs
+                          % " map2=" % timeSpecs
+                          % " map3=" % timeSpecs
+                          % " sql="  % (if nSco then "map2" else "map3")
+                          % "\n"
+            ) t0 t3 t0 t1 t1 t2 t2 t3
+  pure tableMap3
+
 
 -- APIs
 
@@ -1056,8 +1154,6 @@ getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orde
 
 
 
-
-
 apiNgramsTableCorpus :: ( RepoCmdM env err m
                         , HasNodeError err
                         , HasInvalidError err
@@ -1081,3 +1177,9 @@ apiNgramsTableDoc dId =  getTableNgramsDoc dId
                         -- > add new ngrams in database (TODO AD)
                         -- > index all the corpus accordingly (TODO AD)
 
+listNgramsChangedSince :: RepoCmdM env err m => ListId -> NgramsType -> Version -> m (Versioned Bool)
+listNgramsChangedSince listId ngramsType version
+  | version < 0 =
+      Versioned <$> currentVersion <*> pure True
+  | otherwise   =
+      tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)

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,6 +33,10 @@ import qualified Data.Set as Set
 
 type RootTerm = Text
 
+-- 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)

src/Gargantext/API/Node.hs

@@ -7,6 +7,8 @@ Maintainer  : team@gargantext.org
 Stability   : experimental
 Portability : POSIX
 
+-- TODO-SECURITY: Critical
+
 -- TODO-ACCESS: CanGetNode
 -- TODO-EVENTS: No events as this is a read only query.
 Node API
@@ -36,7 +38,7 @@ Node API
 module Gargantext.API.Node
   where
 
-import Control.Lens ((.~), (?~))
+import Control.Lens ((.~), (?~), (^.))
 import Control.Monad ((>>), forM)
 import Control.Monad.IO.Class (liftIO)
 import Data.Aeson (FromJSON, ToJSON)
@@ -46,12 +48,14 @@ import Data.Swagger
 import Data.Text (Text())
 import Data.Time (UTCTime)
 import GHC.Generics (Generic)
+import Gargantext.API.Auth (withAccess, PathId(..))
 import Gargantext.API.Metrics
 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR, TODO)
 import Gargantext.API.Ngrams.NTree (MyTree)
 import Gargantext.API.Search (SearchDocsAPI, searchDocs)
 import Gargantext.API.Table
 import Gargantext.API.Types
+import Gargantext.Core.Types (NodeTableResult)
 import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
 import Gargantext.Database.Config (nodeTypeId)
 import Gargantext.Database.Facet (FacetDoc, OrderBy(..))
@@ -62,7 +66,7 @@ import Gargantext.Database.Tree (treeDB)
 import Gargantext.Database.Types.Node
 import Gargantext.Database.Utils -- (Cmd, CmdM)
 import Gargantext.Prelude
-import Gargantext.Prelude.Utils (hash)
+import Gargantext.Prelude.Utils (sha)
 import Gargantext.Viz.Chart
 import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
 import Servant
@@ -128,7 +132,7 @@ type NodeAPI a = Get '[JSON] (Node a)
              -- TODO gather it
              :<|> "table"     :> TableApi
              :<|> "ngrams"    :> TableNgramsApi
-             :<|> "pairing"   :> PairingApi
+             -- :<|> "pairing"   :> PairingApi
 
              :<|> "category"  :> CatApi
              :<|> "search"    :> SearchDocsAPI
@@ -139,7 +143,7 @@ type NodeAPI a = Get '[JSON] (Node a)
              :<|> "pie"       :> PieApi
              :<|> "tree"      :> TreeApi
              :<|> "phylo"     :> PhyloAPI
-             :<|> "upload"    :> UploadAPI
+             :<|> "add"       :> NodeAddAPI
 
 -- TODO-ACCESS: check userId CanRenameNode nodeId
 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
@@ -155,12 +159,27 @@ type ChildrenApi a = Summary " Summary children"
                  :> QueryParam "type"   NodeType
                  :> QueryParam "offset" Int
                  :> QueryParam "limit"  Int
-                 :> Get '[JSON] [Node a]
+                 -- :> Get '[JSON] [Node a]
+                 :> Get '[JSON] (NodeTableResult a)
+
+------------------------------------------------------------------------
+type NodeNodeAPI a = Get '[JSON] (Node a)
+
+nodeNodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> CorpusId -> NodeId -> GargServer (NodeNodeAPI a)
+nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uId (PathNodeNode cId nId) nodeNodeAPI'
+  where
+    nodeNodeAPI' :: GargServer (NodeNodeAPI a)
+    nodeNodeAPI' = getNode nId p
+
+
+
 ------------------------------------------------------------------------
 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
-nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
-nodeAPI p uId id
-             =  getNode       id p
+nodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
+nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
+  where
+    nodeAPI' :: GargServer (NodeAPI a)
+    nodeAPI' =  getNode       id p
            :<|> rename        id
            :<|> postNode  uId id
            :<|> putNode       id
@@ -170,32 +189,36 @@ nodeAPI p uId id
            -- TODO gather it
            :<|> tableApi             id
            :<|> apiNgramsTableCorpus id
-           :<|> getPairing           id
+           -- :<|> getPairing           id
            -- :<|> getTableNgramsDoc id
-           
+
            :<|> catApi     id
-           
+
            :<|> searchDocs id
-           
+
            :<|> getScatter id
            :<|> getChart   id
            :<|> getPie     id
            :<|> getTree    id
            :<|> phyloAPI   id uId
-           :<|> postUpload id
-  where
+           :<|> nodeAddAPI id
+           -- :<|> postUpload id
+
     deleteNodeApi id' = do
       node <- getNode' id'
       if _node_typename node == nodeTypeId NodeUser
          then panic "not allowed"  -- TODO add proper Right Management Type
          else deleteNode id'
-           
+
            -- Annuaire
            -- :<|> query
+
+
 ------------------------------------------------------------------------
 data RenameNode = RenameNode { r_name :: Text }
   deriving (Generic)
 
+-- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
 instance FromJSON  RenameNode
 instance ToJSON    RenameNode
 instance ToSchema  RenameNode
@@ -206,6 +229,7 @@ data PostNode = PostNode { pn_name :: Text
                          , pn_typename :: NodeType}
   deriving (Generic)
 
+-- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 instance FromJSON  PostNode
 instance ToJSON    PostNode
 instance ToSchema  PostNode
@@ -222,6 +246,7 @@ data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
                                        }
   deriving (Generic)
 
+-- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
 instance FromJSON  NodesToCategory
 instance ToJSON    NodesToCategory
 instance ToSchema  NodesToCategory
@@ -301,8 +326,7 @@ instance HasTreeError ServantErr where
 -}
 
 type TreeAPI   = Get '[JSON] (Tree NodeTree)
--- TODO-ACCESS: CanTree or CanGetNode
--- TODO-EVENTS: No events as this is a read only query.
+
 treeAPI :: NodeId -> GargServer TreeAPI
 treeAPI = treeDB
 
@@ -312,7 +336,10 @@ rename :: NodeId -> RenameNode -> Cmd err [Int]
 rename nId (RenameNode name') = U.update (U.Rename nId name')
 
 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
-postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
+postNode uId pId (PostNode nodeName nt) = do
+  nodeUser <- getNode (NodeId uId) HyperdataUser
+  let uId' = nodeUser ^. node_userId
+  mkNodeWithParent nt (Just pId) uId' nodeName
 
 putNode :: NodeId -> Cmd err Int
 putNode = undefined -- TODO
@@ -354,6 +381,12 @@ instance (ToParamSchema a, HasSwagger sub) =>
         & in_         .~ ParamFormData
         & paramSchema .~ toParamSchema (Proxy :: Proxy a)
 
+type NodeAddAPI = "file" :> Summary "Node add API"
+                         :> UploadAPI
+
+nodeAddAPI :: NodeId -> GargServer NodeAddAPI
+nodeAddAPI id =  postUpload       id
+
 type UploadAPI = Summary "Upload file(s) to a corpus"
                 :> MultipartForm Mem (MultipartData Mem)
                 :> QueryParam "fileType"  FileType
@@ -379,4 +412,4 @@ postUpload _ multipartData (Just fileType) = do
     --pure $ cs content
   -- is <- inputs multipartData
 
-  pure $ map (hash . cs) is
+  pure $ map (sha . cs) is

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,15 +13,16 @@ 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.API.Ngrams (TODO(..))
 
 instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where
   arbitrary = panic "TODO"
@@ -29,21 +30,37 @@ instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where
 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 +79,19 @@ makeLenses ''ScraperInput
 instance FromJSON ScraperInput where
   parseJSON = genericParseJSON $ jsonOptions "_scin_"
 
+-- Proposal to replace the Corpus.API.Query type which seems to generically named.
+data ScraperInput2 = ScraperInput2
+  { _scin2_query     :: !Text
+  , _scin2_corpus    :: !Int
+  , _scin2_databases :: ![ExternalAPIs]
+  }
+  deriving Generic
+
+makeLenses ''ScraperInput2
+
+instance FromJSON ScraperInput2 where
+  parseJSON = genericParseJSON $ jsonOptions "_scin2_"
+
 data ScraperEvent = ScraperEvent
   { _scev_message :: !(Maybe Text)
   , _scev_level   :: !(Maybe Text)
@@ -100,14 +130,16 @@ instance FromJSON ScraperStatus where
 instance ToSchema ScraperStatus -- TODO _scst_ prefix
 
 instance ToSchema ScraperInput  -- TODO _scin_ prefix
+instance ToSchema ScraperInput2 -- TODO _scin2_ 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
+type ScraperAPI2 = AsyncJobsAPI ScraperStatus ScraperInput2 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,9 +74,7 @@ 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
@@ -92,12 +88,14 @@ type SearchAPI results
  :> Post '[JSON] results
 
 type SearchDocsAPI  = SearchAPI SearchDocResults
-type SearchPairsAPI = SearchAPI SearchPairedResults
+type SearchPairsAPI = 
+  Summary "" :> "list"  :> Capture "list"   ListId
+  :> SearchAPI SearchPairedResults
 -----------------------------------------------------------------------
 
 searchPairs :: NodeId -> GargServer SearchPairsAPI
-searchPairs pId (SearchQuery q) o l order =
-  SearchPairedResults <$> searchInCorpusWithContacts pId q o l order
+searchPairs pId lId (SearchQuery q) o l order =
+  SearchPairedResults <$> searchInCorpusWithContacts pId lId q o l order
 
 searchDocs :: NodeId -> GargServer SearchDocsAPI
 searchDocs nId (SearchQuery 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
   }
@@ -232,10 +234,13 @@ readRepoEnv = do
   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 +248,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 +257,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 +300,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(..))
 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,35 +70,58 @@ 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
          -> Maybe Offset  -> Maybe Limit
          -> Maybe OrderBy -> Cmd err [FacetDoc]
@@ -108,4 +131,4 @@ getPairing cId ft 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,116 @@ 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.
+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
+
+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

@@ -12,8 +12,6 @@ Portability : POSIX
 module Gargantext.Core
   where
 
-
-
 ------------------------------------------------------------------------
 -- | Language of a Text
 -- For simplicity, we suppose text has an homogenous language

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,21 +23,28 @@ module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
                              , Label, Stems
                              , HasInvalidError(..), assertValid
                              , Name
+                             , TableResult(..)
+                             , NodeTableResult
                              ) where
 
 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 Data.Swagger (ToSchema(..), genericDeclareNamedSchema)
 --import qualified Data.Set as S
 
 import Data.Text (Text, unpack)
 import Data.Validity
 
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+
 import Gargantext.Core.Types.Main
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Types.Node
 import Gargantext.Prelude
 
@@ -135,3 +143,18 @@ 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)

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,36 +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
@@ -127,17 +100,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 +116,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
@@ -90,4 +94,9 @@ 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,14 +54,11 @@ 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.NodeNode
 import Gargantext.Database.Utils
-import Gargantext.Database.Queries.Join
 import Gargantext.Database.Queries.Filter
 import Opaleye
 import Prelude hiding (null, id, map, sum, not, read)
@@ -70,9 +80,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 +109,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 +168,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 +206,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
@@ -224,18 +237,19 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
                                 .== nng_node_id nodeNgram
 
          cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
-         cond23 (ngrams, (nodeNgram, _)) =  ngrams_id                  ngrams
+         cond23 (ngrams, (nodeNgram, _)) =  ngrams^.ngrams_id
                                         .== nng_ngrams_id nodeNgram
-         
+
          cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
-         cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams     .== nng_ngrams_id       nodeNgram2
-         
+         cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams^.ngrams_id .== nng_ngrams_id       nodeNgram2
+
          cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
          cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== nng_node_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,12 +260,12 @@ 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)
 
 
 ------------------------------------------------------------------------

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 :: AnnuaireId
+        -> CorpusId
+        -> ListId
+        -> Cmd err Int
+pairing aId cId 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,27 @@ 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 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 +142,3 @@ selectNgramsTindexed corpusId ngramsType = proc () -> do
     result <- aggregate groupBy (ngrams_id ngrams)
     returnA -< result
 --}
-
-

src/Gargantext/Database/Flow/Utils.hs

@@ -22,25 +22,30 @@ import Gargantext.Prelude
 import Gargantext.Database.Schema.Ngrams
 import Gargantext.Database.Types.Node (NodeId, Node, NodePoly(..), Hyperdata)
 import Gargantext.Database.Utils (Cmd)
-import Gargantext.Database.Schema.NodeNgram
 import Gargantext.Database.Schema.NodeNodeNgrams
 import Gargantext.Database.Types.Node
-import Gargantext.Core.Types.Main (ListType(..), listTypeId)
 
-toMaps :: Hyperdata a => (a -> Map (NgramsT Ngrams) Int) -> [Node a] -> Map (NgramsT Ngrams) (Map NodeId Int)
+toMaps :: Hyperdata a
+       => (a -> Map (NgramsT Ngrams) Int)
+       -> [Node a]
+       -> Map (NgramsT Ngrams) (Map NodeId Int)
 toMaps fun ns = mapNodeIdNgrams $ documentIdWithNgrams fun ns'
   where
     ns' = map (\(Node nId _ _ _ _ _ json) -> DocumentWithId nId json) ns
 
-mapNodeIdNgrams :: Hyperdata a => [DocumentIdWithNgrams a] -> Map (NgramsT Ngrams) (Map NodeId Int)
+mapNodeIdNgrams :: Hyperdata a
+                => [DocumentIdWithNgrams a]
+                -> Map (NgramsT Ngrams) (Map NodeId Int)
 mapNodeIdNgrams ds = DM.map (DM.fromListWith (+)) $ DM.fromListWith (<>) xs
   where
     xs  = [(ng, [(nId, i)]) | (nId, n2i') <- n2i ds, (ng, i) <- DM.toList n2i']
     n2i = map (\d -> ((documentId . documentWithId) d, document_ngrams d))
 
 
-documentIdWithNgrams :: Hyperdata a => (a -> Map (NgramsT Ngrams) Int)
-                                     -> [DocumentWithId a] -> [DocumentIdWithNgrams a]
+documentIdWithNgrams :: Hyperdata a
+                     => (a -> Map (NgramsT Ngrams) Int)
+                     -> [DocumentWithId a]
+                     -> [DocumentIdWithNgrams a]
 documentIdWithNgrams f = map (\d -> DocumentIdWithNgrams d ((f . documentData) d))
 
 
@@ -56,19 +61,12 @@ data DocumentIdWithNgrams a =
      , document_ngrams :: Map (NgramsT Ngrams) Int
      } deriving (Show)
 
--- | TODO for now, list Type is CandidateTerm because Graph Terms
--- have to be detected in next step in the flow
--- TODO remvoe this
-insertToNodeNgrams :: Map NgramsIndexed (Map NgramsType (Map NodeId Int)) -> Cmd err Int
-insertToNodeNgrams m = insertNodeNgrams [ NodeNgram n (_ngramsId ng) Nothing (ngramsTypeId t) (listTypeId CandidateTerm) (fromIntegral i)
-                                        | (ng, t2n2i) <- DM.toList m
-                                        , (t,  n2i)   <- DM.toList t2n2i
-                                        , (n,  i)     <- DM.toList n2i
-                                        ]
 
-
-docNgrams2nodeNodeNgrams :: CorpusId -> DocNgrams -> NodeNodeNgrams
-docNgrams2nodeNodeNgrams cId (DocNgrams d n nt w) = NodeNodeNgrams Nothing cId d n nt w
+docNgrams2nodeNodeNgrams :: CorpusId
+                         -> DocNgrams
+                         -> NodeNodeNgrams
+docNgrams2nodeNodeNgrams cId (DocNgrams d n nt w) =
+  NodeNodeNgrams Nothing cId d n nt w
 
 data DocNgrams = DocNgrams { dn_doc_id :: DocId
                            , dn_ngrams_id :: Int
@@ -76,13 +74,20 @@ data DocNgrams = DocNgrams { dn_doc_id :: DocId
                            , dn_weight  :: Double
                            }
 
-insertDocNgramsOn :: CorpusId -> [DocNgrams] -> Cmd err Int
-insertDocNgramsOn cId dn = insertNodeNodeNgrams $ (map (docNgrams2nodeNodeNgrams cId) dn)
-
-insertDocNgrams :: CorpusId -> Map NgramsIndexed (Map NgramsType (Map NodeId Int)) -> Cmd err Int
-insertDocNgrams cId m = insertDocNgramsOn cId [ DocNgrams n (_ngramsId ng) (ngramsTypeId t) (fromIntegral i)
-                                        | (ng, t2n2i) <- DM.toList m
-                                        , (t,  n2i)   <- DM.toList t2n2i
-                                        , (n,  i)     <- DM.toList n2i
-                                        ]
+insertDocNgramsOn :: CorpusId
+                  -> [DocNgrams]
+                  -> Cmd err Int
+insertDocNgramsOn cId dn =
+  insertNodeNodeNgrams
+  $ (map (docNgrams2nodeNodeNgrams cId) dn)
+
+insertDocNgrams :: CorpusId
+                -> Map NgramsIndexed (Map NgramsType (Map NodeId Int))
+                -> Cmd err Int
+insertDocNgrams cId m =
+  insertDocNgramsOn cId [ DocNgrams n (_ngramsId ng) (ngramsTypeId t) (fromIntegral i)
+                          | (ng, t2n2i) <- DM.toList m
+                          , (t,  n2i)   <- DM.toList t2n2i
+                          , (n,  i)     <- DM.toList n2i
+                        ]
 

src/Gargantext/Database/Ngrams.hs

@@ -18,6 +18,7 @@ module Gargantext.Database.Ngrams
     where
 
 import Data.Text (Text)
+import Control.Lens ((^.))
 import Gargantext.Core.Types
 import Gargantext.Database.Utils (runOpaQuery, Cmd)
 import Gargantext.Database.Schema.Ngrams
@@ -27,21 +28,21 @@ import Gargantext.Prelude
 import Opaleye
 import Control.Arrow (returnA)
 
-selectNgramsByDoc :: [CorpusId] -> DocId -> NgramsType -> Cmd err [Text]
-selectNgramsByDoc cIds dId nt = runOpaQuery (query cIds dId nt)
+selectNgramsByDoc :: [ListId] -> DocId -> NgramsType -> Cmd err [Text]
+selectNgramsByDoc lIds dId nt = runOpaQuery (query lIds dId nt)
   where
-    
+
     join :: Query (NgramsRead, NodeNodeNgramsReadNull)
     join = leftJoin queryNgramsTable queryNodeNodeNgramsTable on1
       where
-        on1 (ng,nnng) = ngrams_id ng .== nnng_ngrams_id nnng
+        on1 (ng,nnng) = ng^.ngrams_id .== nnng^.nnng_ngrams_id
 
     query cIds' dId' nt' = proc () -> do
       (ng,nnng) <- join -< ()
-      restrict -< foldl (\b cId -> ((toNullable $ pgNodeId cId) .== nnng_node1_id nnng) .|| b) (pgBool True) cIds'
-      restrict -< (toNullable $ pgNodeId dId') .== nnng_node2_id nnng
-      restrict -< (toNullable $ pgNgramsType nt') .== nnng_ngramsType nnng
-      returnA -< ngrams_terms ng
+      restrict -< foldl (\b cId -> ((toNullable $ pgNodeId cId) .== nnng^.nnng_node1_id) .|| b) (pgBool True) cIds'
+      restrict -< (toNullable $ pgNodeId dId')    .== nnng^.nnng_node2_id
+      restrict -< (toNullable $ pgNgramsType nt') .== nnng^.nnng_ngramsType
+      returnA  -< ng^.ngrams_terms
 
 
 postNgrams :: CorpusId -> DocId -> [Text] -> Cmd err Int

src/Gargantext/Database/Node/Children.hs

@@ -18,6 +18,7 @@ Portability : POSIX
 
 module Gargantext.Database.Node.Children where
 
+import Data.Proxy
 import Opaleye
 import Gargantext.Core.Types
 import Gargantext.Database.Schema.Node
@@ -29,30 +30,52 @@ import Gargantext.Database.Node.Contact (HyperdataContact)
 import Gargantext.Database.Schema.Node (pgNodeId)
 import Control.Arrow (returnA)
 
--- | TODO: use getChildren with Proxy ?
-getContacts :: ParentId -> Maybe NodeType -> Cmd err [Node HyperdataContact]
-getContacts pId maybeNodeType = runOpaQuery $ selectChildren pId maybeNodeType
+getAllDocuments :: ParentId -> Cmd err (TableResult (Node HyperdataDocument))
+getAllDocuments pId = getAllChildren pId (Proxy :: Proxy HyperdataDocument)
+                                         (Just NodeDocument)
 
+getAllContacts :: ParentId -> Cmd err (TableResult (Node HyperdataContact))
+getAllContacts pId = getAllChildren pId (Proxy :: Proxy HyperdataContact)
+                                        (Just NodeContact)
 
-getChildren :: JSONB a => ParentId -> proxy a -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
-getChildren pId _ maybeNodeType maybeOffset maybeLimit = runOpaQuery
-                  $ limit' maybeLimit $ offset' maybeOffset
-                  $ orderBy (asc _node_id)
-                  $ selectChildren pId maybeNodeType
+getAllChildren :: JSONB a
+               => ParentId
+               -> proxy a
+               -> Maybe NodeType
+               -> Cmd err (NodeTableResult a)
+getAllChildren pId p maybeNodeType = getChildren pId p maybeNodeType Nothing Nothing
 
-selectChildren :: ParentId -> Maybe NodeType -> Query NodeRead
+getChildren :: JSONB a
+            => ParentId
+            -> proxy a
+            -> Maybe NodeType
+            -> Maybe Offset
+            -> Maybe Limit
+            -> Cmd err (NodeTableResult a)
+getChildren pId _ maybeNodeType maybeOffset maybeLimit = do
+  docs <- runOpaQuery
+          $ limit' maybeLimit $ offset' maybeOffset
+          $ orderBy (asc _node_id)
+          $ query
+
+  docCount <- runCountOpaQuery query
+
+  pure $ TableResult { tr_docs = docs, tr_count = docCount }
+
+  where
+    query = selectChildren pId maybeNodeType
+
+selectChildren :: ParentId
+               -> Maybe NodeType
+               -> Query NodeRead
 selectChildren parentId maybeNodeType = proc () -> do
     row@(Node nId typeName _ parent_id _ _ _) <- queryNodeTable -< ()
     (NodeNode n1id n2id _ _) <- queryNodeNodeTable -< ()
-    
+
     let nodeType = maybe 0 nodeTypeId maybeNodeType
     restrict -< typeName  .== pgInt4 nodeType
-    
+
     restrict -< (.||) (parent_id .== (pgNodeId parentId))
                       ( (.&&) (n1id .== pgNodeId parentId)
                               (n2id .== nId))
     returnA -< row
-
-
-
-

src/Gargantext/Database/Node/Contact.hs

@@ -22,12 +22,12 @@ module Gargantext.Database.Node.Contact
 
 import Control.Lens (makeLenses)
 import Data.Aeson.TH (deriveJSON)
-import Data.Swagger (ToSchema)
+import Data.Swagger (ToSchema(..), genericDeclareNamedSchema)
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
 import GHC.Generics (Generic)
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Core.Types (Name)
 import Gargantext.Database.Schema.Node (NodeWrite, node)
 import Gargantext.Database.Types.Node (Node,Hyperdata,NodeType(..), UserId, AnnuaireId)
@@ -76,15 +76,15 @@ data ContactWho =
 data ContactWhere =
      ContactWhere { _cw_organization :: [Text]
                   , _cw_labTeamDepts :: [Text]
-                  
+
                   , _cw_role         :: Maybe Text
-                  
+
                   , _cw_office       :: Maybe Text
                   , _cw_country      :: Maybe Text
                   , _cw_city         :: Maybe Text
-                  
+
                   , _cw_touch        :: Maybe ContactTouch
-                  
+
                   , _cw_entry        :: Maybe UTCTime
                   , _cw_exit         :: Maybe UTCTime
   } deriving (Eq, Show, Generic)
@@ -105,16 +105,22 @@ nodeContactW maybeName maybeContact aId =
       contact = maybe arbitraryHyperdataContact identity maybeContact
 
 
--- | Main instances of Contact
-instance ToSchema HyperdataContact
-instance ToSchema ContactWho
-instance ToSchema ContactWhere
-instance ToSchema ContactTouch
+-- | ToSchema instances
+instance ToSchema HyperdataContact where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hc_")
+instance ToSchema ContactWho where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_cw_")
+instance ToSchema ContactWhere where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_cw_")
+instance ToSchema ContactTouch where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ct_")
+instance ToSchema ContactMetaData where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_cm_")
 
+-- | Arbitrary instances
 instance Arbitrary HyperdataContact where
   arbitrary = elements [HyperdataContact Nothing Nothing [] Nothing Nothing Nothing Nothing Nothing]
 
-
 -- | Specific Gargantext instance
 instance Hyperdata HyperdataContact
 

src/Gargantext/Database/Node/Document/Insert.hs

@@ -39,7 +39,7 @@ database (in others words parent_id is necessary to preserve privacy for
 instance).
 
 - Hash policy: this UniqId is a sha256 uniq id which is the result of
-the concatenation of the parameters defined by @hashParameters@.
+the concatenation of the parameters defined by @shaParameters@.
 
 > -- * Example
 > insertTest :: FromRow r => CorpusId -> [Node HyperdataDocument] -> IO [r]
@@ -79,7 +79,7 @@ import Gargantext.Prelude
 import qualified Data.ByteString.Lazy.Char8  as DC (pack)
 import qualified Data.Digest.Pure.SHA        as SHA (sha256, showDigest)
 import qualified Data.Text                   as DT (pack, unpack, concat, take)
-import Gargantext.Prelude.Utils (hash)
+import Gargantext.Prelude.Utils (sha)
 -- TODO : the import of Document constructor below does not work
 -- import Gargantext.Database.Types.Node (Document)
 --import Gargantext.Database.Types.Node (docExample, hyperdataDocument, HyperdataDocument(..)
@@ -186,7 +186,7 @@ queryInsert = [sql|
 data ReturnId = ReturnId { reInserted :: Bool -- if the document is inserted (True: is new, False: is not new)
                          , reId       :: NodeId  -- always return the id of the document (even new or not new)
                                          --   this is the uniq id in the database
-                         , reUniqId   :: Text -- Hash Id with concatenation of hash parameters
+                         , reUniqId   :: Text -- Hash Id with concatenation of sha parameters
                          } deriving (Show, Generic)
 
 instance FromRow ReturnId where
@@ -204,14 +204,14 @@ instance AddUniqId HyperdataDocument
     addUniqId = addUniqIdsDoc
       where
         addUniqIdsDoc :: HyperdataDocument -> HyperdataDocument
-        addUniqIdsDoc doc = set hyperdataDocument_uniqIdBdd (Just hashBdd)
-                          $ set hyperdataDocument_uniqId    (Just hashUni) doc
+        addUniqIdsDoc doc = set hyperdataDocument_uniqIdBdd (Just shaBdd)
+                          $ set hyperdataDocument_uniqId    (Just shaUni) doc
           where
-            hashUni = hash $ DT.concat $ map ($ doc) hashParametersDoc
-            hashBdd = hash $ DT.concat $ map ($ doc) ([(\d -> maybeText (_hyperdataDocument_bdd d))] <> hashParametersDoc)
+            shaUni = sha $ DT.concat $ map ($ doc) shaParametersDoc
+            shaBdd = sha $ DT.concat $ map ($ doc) ([(\d -> maybeText (_hyperdataDocument_bdd d))] <> shaParametersDoc)
 
-        hashParametersDoc :: [(HyperdataDocument -> Text)]
-        hashParametersDoc = [ \d -> maybeText (_hyperdataDocument_title    d)
+        shaParametersDoc :: [(HyperdataDocument -> Text)]
+        shaParametersDoc = [ \d -> maybeText (_hyperdataDocument_title    d)
                             , \d -> maybeText (_hyperdataDocument_abstract d)
                             , \d -> maybeText (_hyperdataDocument_source   d)
                             , \d -> maybeText (_hyperdataDocument_publication_date   d)
@@ -226,18 +226,18 @@ instance AddUniqId HyperdataContact
     addUniqId = addUniqIdsContact
 
 addUniqIdsContact :: HyperdataContact -> HyperdataContact
-addUniqIdsContact hc = set (hc_uniqIdBdd) (Just hashBdd)
-                     $ set (hc_uniqId   ) (Just hashUni) hc
+addUniqIdsContact hc = set (hc_uniqIdBdd) (Just shaBdd)
+                     $ set (hc_uniqId   ) (Just shaUni) hc
   where
-    hashUni = uniqId $ DT.concat $ map ($ hc) hashParametersContact
-    hashBdd = uniqId $ DT.concat $ map ($ hc) ([\d -> maybeText (view hc_bdd d)] <> hashParametersContact)
+    shaUni = uniqId $ DT.concat $ map ($ hc) shaParametersContact
+    shaBdd = uniqId $ DT.concat $ map ($ hc) ([\d -> maybeText (view hc_bdd d)] <> shaParametersContact)
 
     uniqId :: Text -> Text
     uniqId = DT.pack . SHA.showDigest . SHA.sha256 . DC.pack . DT.unpack
 
-    -- | TODO add more hashparameters
-    hashParametersContact :: [(HyperdataContact -> Text)]
-    hashParametersContact = [ \d -> maybeText $ view (hc_who . _Just . cw_firstName) d
+    -- | TODO add more shaparameters
+    shaParametersContact :: [(HyperdataContact -> Text)]
+    shaParametersContact = [ \d -> maybeText $ view (hc_who . _Just . cw_firstName) d
                             , \d -> maybeText $ view (hc_who . _Just . cw_lastName ) d
                             , \d -> maybeText $ view (hc_where . _head . cw_touch . _Just . ct_mail) d
                             ]

src/Gargantext/Database/Node/Update.hs

@@ -41,6 +41,7 @@ data Update = Rename NodeId Name
 unOnly :: Only a -> a
 unOnly (Only a) = a
 
+-- TODO-ACCESS
 update :: Update -> Cmd err [Int]
 update (Rename nId name) = map unOnly <$> runPGSQuery "UPDATE nodes SET name=? where id=? returning id"
                                            (DT.take 255 name,nId)

src/Gargantext/Database/Node/UpdateOpaleye.hs

+{-|
+Module      : Gargantext.Database.Node.UpdateOpaleye
+Description : Update Node in Database (Postgres)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE RankNTypes        #-}
+
+
+module Gargantext.Database.Node.UpdateOpaleye where
+
+
+import Opaleye
+import Data.Aeson (encode, ToJSON)
+import Gargantext.Prelude
+import Gargantext.Database.Schema.Node 
+import Gargantext.Database.Types.Node
+import Gargantext.Database.Utils (Cmd, mkCmd)
+
+updateHyperdata :: ToJSON a => NodeId -> a -> Cmd err Int64
+updateHyperdata i h = mkCmd $ \c -> runUpdate_ c (updateHyperdataQuery i h)
+
+updateHyperdataQuery :: ToJSON a => NodeId -> a -> Update Int64
+updateHyperdataQuery i h = Update
+   { uTable      = nodeTable
+   , uUpdateWith = updateEasy (\  (Node _ni _nt _nu _np _nn _nd _h)
+                                -> Node _ni _nt _nu _np _nn _nd h'
+                              )
+   , uWhere      = (\row -> _node_id row .== pgNodeId i )
+   , uReturning  = rCount
+   }
+    where h' =  (pgJSONB $ cs $ encode $ h)
+

src/Gargantext/Database/Queries/Join.hs

@@ -64,7 +64,9 @@ leftJoin3
      -> ((fieldsL2, fieldsR) -> Column PGBool)
      -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
      -> Opaleye.Select (fieldsL1, nullableFieldsR2)
-leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q2 q1 cond12) cond23
+leftJoin3 q1 q2     q3
+         cond12 cond23 =
+  leftJoin q3 ( leftJoin q2 q1 cond12) cond23
 
 
 leftJoin4
@@ -85,7 +87,13 @@ leftJoin4
      -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
      -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
      -> Opaleye.Select (fieldsL1, nullableFieldsR3)
-leftJoin4 q1 q2 q3 q4 cond12 cond23 cond34 = leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34
+leftJoin4 q1 q2     q3     q4
+         cond12 cond23 cond34 =
+  leftJoin q4 ( leftJoin q3
+                ( leftJoin q2 q1
+                    cond12
+                ) cond23
+              ) cond34
 
 
 leftJoin5 :: ( Default Unpackspec fieldsL1 fieldsL1,
@@ -110,7 +118,15 @@ leftJoin5 :: ( Default Unpackspec fieldsL1 fieldsL1,
                -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
                -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
                -> Query (fieldsL1, nullableFieldsR4)
-leftJoin5 q1 q2 q3 q4 q5 cond12 cond23 cond34 cond45 = leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45
+leftJoin5 q1 q2     q3     q4     q5
+         cond12 cond23 cond34 cond45 =
+  leftJoin q5 ( leftJoin q4
+                ( leftJoin q3
+                  ( leftJoin q2 q1
+                       cond12
+                   ) cond23
+                 ) cond34
+               ) cond45
 
 
 leftJoin6 :: ( Default Unpackspec fieldsL1 fieldsL1,
@@ -139,7 +155,17 @@ leftJoin6 :: ( Default Unpackspec fieldsL1 fieldsL1,
      -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
      -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
      -> Query (fieldsL1, nullableFieldsR5)
-leftJoin6 q1 q2 q3 q4 q5 q6 cond12 cond23 cond34 cond45 cond56 = leftJoin q6 (leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45) cond56
+leftJoin6 q1 q2     q3     q4     q5     q6
+         cond12 cond23 cond34 cond45 cond56 =
+  leftJoin q6 ( leftJoin q5
+                ( leftJoin q4
+                  ( leftJoin q3
+                    ( leftJoin q2 q1
+                         cond12
+                     ) cond23
+                  ) cond34
+                ) cond45
+              ) cond56
 
 
 leftJoin7
@@ -175,7 +201,19 @@ leftJoin7
      -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
      -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
      -> Opaleye.Select (fieldsL1, nullableFieldsR6)
-leftJoin7 q1 q2 q3 q4 q5 q6 q7 cond12 cond23 cond34 cond45 cond56 cond67 = leftJoin q7 (leftJoin q6 (leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45) cond56) cond67
+leftJoin7 q1 q2     q3     q4     q5     q6     q7
+         cond12 cond23 cond34 cond45 cond56 cond67 =
+  leftJoin q7 ( leftJoin q6
+                ( leftJoin q5
+                  ( leftJoin q4
+                    ( leftJoin q3
+                      ( leftJoin q2 q1
+                       cond12
+                    ) cond23
+                   ) cond34
+                  ) cond45
+                 ) cond56
+                ) cond67
 
 
 leftJoin8
@@ -216,7 +254,21 @@ leftJoin8
      -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
      -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
      -> Opaleye.Select (fieldsL1, nullableFieldsR7)
-leftJoin8 q1 q2 q3 q4 q5 q6 q7 q8 cond12 cond23 cond34 cond45 cond56 cond67 cond78 = leftJoin q8 (leftJoin q7 (leftJoin q6 (leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45) cond56) cond67) cond78
+leftJoin8 q1 q2     q3     q4     q5     q6     q7     q8
+         cond12 cond23 cond34 cond45 cond56 cond67 cond78 =
+  leftJoin q8 ( leftJoin q7
+                ( leftJoin q6
+                  ( leftJoin q5
+                    ( leftJoin q4
+                      ( leftJoin q3
+                        ( leftJoin q2 q1
+                             cond12
+                        ) cond23
+                      ) cond34
+                    ) cond45
+                  ) cond56
+                ) cond67
+              ) cond78
 
 
 leftJoin9
@@ -262,5 +314,21 @@ leftJoin9
      -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
      -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
      -> Opaleye.Select (fieldsL1, nullableFieldsR8)
-leftJoin9 q1 q2 q3 q4 q5 q6 q7 q8 q9 cond12 cond23 cond34 cond45 cond56 cond67 cond78 cond89 = leftJoin q9 (leftJoin q8 (leftJoin q7 (leftJoin q6 (leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45) cond56) cond67) cond78) cond89
+leftJoin9   q1 q2    q3     q4     q5     q6      q7    q8     q9
+          cond12 cond23 cond34 cond45 cond56 cond67 cond78 cond89 =
+  leftJoin q9 ( leftJoin q8
+                ( leftJoin q7
+                  ( leftJoin q6
+                    ( leftJoin q5
+                      ( leftJoin q4
+                        ( leftJoin q3
+                          ( leftJoin q2 q1
+                              cond12
+                          ) cond23
+                        ) cond34
+                      ) cond45
+                    ) cond56
+                  ) cond67
+                ) cond78
+              ) cond89
 

src/Gargantext/Database/Schema/Ngrams.hs

@@ -51,9 +51,9 @@ type NgramsId    = Int
 type NgramsTerms = Text
 type Size        = Int
 
-data NgramsPoly id terms n = NgramsDb { ngrams_id    :: id
-                                      , ngrams_terms :: terms
-                                      , ngrams_n     :: n
+data NgramsPoly id terms n = NgramsDb { _ngrams_id    :: id
+                                      , _ngrams_terms :: terms
+                                      , _ngrams_n     :: n
                                       } deriving (Show)
 
 type NgramsWrite = NgramsPoly (Maybe (Column PGInt4))
@@ -71,12 +71,13 @@ type NgramsReadNull = NgramsPoly (Column (Nullable PGInt4))
 type NgramsDb = NgramsPoly Int Text Int
 
 $(makeAdaptorAndInstance "pNgramsDb"    ''NgramsPoly)
--- $(makeLensesWith abbreviatedFields   ''NgramsPoly)
+makeLenses ''NgramsPoly
+
 
 ngramsTable :: Table NgramsWrite NgramsRead
-ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { ngrams_id    = optional "id"
-                                                 , ngrams_terms = required "terms"
-                                                 , ngrams_n     = required "n"
+ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { _ngrams_id    = optional "id"
+                                                 , _ngrams_terms = required "terms"
+                                                 , _ngrams_n     = required "n"
                                                  }
                               )
 

src/Gargantext/Database/Schema/Node.hs

@@ -44,6 +44,7 @@ import Gargantext.Database.Queries.Filter (limit', offset')
 import Gargantext.Database.Types.Node (NodeType(..), defaultCorpus, Hyperdata, HyperData(..))
 import Gargantext.Database.Utils
 import Gargantext.Prelude hiding (sum, head)
+import Gargantext.Viz.Graph (HyperdataGraph(..))
 
 import Opaleye hiding (FromField)
 import Opaleye.Internal.QueryArr (Query)
@@ -218,11 +219,11 @@ nodeTable :: Table NodeWrite NodeRead
 nodeTable = Table "nodes" (pNode Node { _node_id         = optional "id"
                                       , _node_typename   = required "typename"
                                       , _node_userId     = required "user_id"
-                                      
+
                                       , _node_parentId   = optional "parent_id"
                                       , _node_name       = required "name"
                                       , _node_date       = optional "date"
-                                      
+
                                       , _node_hyperdata  = required "hyperdata"
                                       }
                             )
@@ -266,21 +267,19 @@ type NodeSearchReadNull =
     (Column (Nullable PGJsonb)      )
     (Column (Nullable PGTSVector)   )
 
---{-
 nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
 nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id         = optional "id"
                                       , _ns_typename   = required "typename"
                                       , _ns_userId     = required "user_id"
-                                      
+
                                       , _ns_parentId   = required "parent_id"
                                       , _ns_name       = required "name"
                                       , _ns_date       = optional "date"
-                                      
+
                                       , _ns_hyperdata  = required "hyperdata"
                                       , _ns_search     = optional "search"
                                       }
                             )
---}
 
 queryNodeSearchTable :: Query NodeSearchRead
 queryNodeSearchTable = queryTable nodeTableSearch
@@ -374,17 +373,17 @@ type JSONB = QueryRunnerColumnDefault PGJsonb
 
 getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
 getNode nId _ = do
-    fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
+    fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 
 getNodePhylo :: NodeId -> Cmd err (Node HyperdataPhylo)
 getNodePhylo nId = do
-    fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
+    fromMaybe (error $ "Node Phylo does not exist: " <> show nId) . headMay
              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 
 
 getNode' :: NodeId -> Cmd err (Node Value)
-getNode' nId = fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
+getNode' nId = fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 
 
@@ -434,7 +433,6 @@ nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Jus
     name     = maybe "Annuaire" identity maybeName
     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 
-
 ------------------------------------------------------------------------
 
 {-
@@ -498,7 +496,7 @@ nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just
 
 ------------------------------------------------------------------------
 arbitraryGraph :: HyperdataGraph
-arbitraryGraph = HyperdataGraph (Just "Preferences")
+arbitraryGraph = HyperdataGraph Nothing
 
 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
@@ -506,6 +504,12 @@ nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
     name = maybe "Graph" identity maybeName
     graph = maybe arbitraryGraph identity maybeGraph
 
+mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
+mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
+
+insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
+insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
+
 ------------------------------------------------------------------------
 arbitraryPhylo :: HyperdataPhylo
 arbitraryPhylo = HyperdataPhylo Nothing Nothing
@@ -518,10 +522,8 @@ nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
 
 
 ------------------------------------------------------------------------
-
 arbitraryDashboard :: HyperdataDashboard
 arbitraryDashboard = HyperdataDashboard (Just "Preferences")
-
 ------------------------------------------------------------------------
 
 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
@@ -582,6 +584,7 @@ data NewNode = NewNode { _newNodeId :: NodeId
                        , _newNodeChildren :: [NodeId] }
 
 postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
+
 postNode uid pid (Node' nt txt v []) = do
   pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
   case pids of
@@ -597,6 +600,7 @@ postNode uid pid (Node' NodeAnnuaire txt v ns) = do
   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
   pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
   pure $ NewNode pid' pids
+
 postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
 
 
@@ -614,7 +618,45 @@ mkNodeWithParent NodeUser Nothing  uId name =
     where
       hd = HyperdataUser . Just . pack $ show EN
 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
-mkNodeWithParent _ _ _ _ = nodeError NotImplYet
+
+------------------------------------------------------------------------
+mkNodeWithParent NodeFolder (Just i) uId name = 
+   insertNodesWithParentR (Just i) [node NodeFolder name hd Nothing uId]
+    where
+      hd = HyperdataFolder . Just . pack $ show EN
+
+mkNodeWithParent NodeFolderPrivate (Just i) uId _ = 
+   insertNodesWithParentR (Just i) [node NodeFolderPrivate "Private" hd Nothing uId]
+    where
+      hd = HyperdataFolder . Just . pack $ show EN
+
+mkNodeWithParent NodeFolderShared (Just i) uId _ = 
+   insertNodesWithParentR (Just i) [node NodeFolderShared "Shared" hd Nothing uId]
+    where
+      hd = HyperdataFolder . Just . pack $ show EN
+
+mkNodeWithParent NodeFolderPublic (Just i) uId _ = 
+   insertNodesWithParentR (Just i) [node NodeFolderPublic "Public" hd Nothing uId]
+    where
+      hd = HyperdataFolder . Just . pack $ show EN
+
+mkNodeWithParent NodeTeam (Just i) uId _ = 
+   insertNodesWithParentR (Just i) [node NodeTeam "Team" hd Nothing uId]
+    where
+      hd = HyperdataFolder . Just . pack $ show EN
+
+
+------------------------------------------------------------------------
+
+
+
+mkNodeWithParent NodeCorpus (Just i) uId name =
+   insertNodesWithParentR (Just i) [node NodeCorpus name hd Nothing uId]
+    where
+      hd = defaultCorpus
+
+mkNodeWithParent _ _ _ _       = nodeError NotImplYet
+
 
 
 mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
@@ -655,10 +697,6 @@ defaultList cId =
 mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 mkNode nt p u = insertNodesR [nodeDefault nt p u]
 
-
-mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
-mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
-
 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
   where
@@ -669,7 +707,6 @@ mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
         dashboard = maybe arbitraryDashboard identity maybeDashboard
 
 
-
 mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
 mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
 
@@ -678,8 +715,5 @@ mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
 pgNodeId :: NodeId -> Column PGInt4
 pgNodeId = pgInt4 . id2int
 
-
 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
-
-

src/Gargantext/Database/Schema/NodeNgram.hs

-{-|
-Module      : Gargantext.Database.Schema.NodeNgrams
-Description : NodeNgram for Ngram indexation or Lists
-Copyright   : (c) CNRS, 2017-Present
-License     : AGPL + CECILL v3
-Maintainer  : team@gargantext.org
-Stability   : experimental
-Portability : POSIX
-
-NodeNgram: relation between a Node and a Ngrams
-
-if Node is a Document then it is indexing
-if Node is a List     then it is listing (either Stop, Candidate or Map)
-
--}
-
-{-# OPTIONS_GHC -fno-warn-orphans   #-}
-
-{-# LANGUAGE Arrows                     #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE FunctionalDependencies     #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE QuasiQuotes                #-}
-{-# LANGUAGE RankNTypes                 #-}
-{-# LANGUAGE TemplateHaskell            #-}
-
-
--- TODO NodeNgrams
-module Gargantext.Database.Schema.NodeNgram where
-
-import Data.ByteString (ByteString)
-import Data.Text (Text)
-import Control.Lens.TH (makeLenses)
-import Control.Monad (void)
-import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
-import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
-import Database.PostgreSQL.Simple.SqlQQ (sql)
-import Gargantext.Database.Utils (mkCmd, Cmd, execPGSQuery)
-import Gargantext.Core.Types.Main (ListTypeId)
-import Gargantext.Database.Types.Node (NodeId, ListId)
-import Gargantext.Database.Schema.Node (pgNodeId)
-import Gargantext.Database.Schema.Ngrams (NgramsTypeId, pgNgramsTypeId)
-import Gargantext.Prelude
-import Gargantext.Database.Utils (formatPGSQuery)
-import Opaleye
-import qualified Database.PostgreSQL.Simple as DPS
-
--- | TODO : remove id
-data NodeNgramPoly node_id ngrams_id parent_id ngrams_type list_type weight
-   = NodeNgram { nng_node_id    :: node_id
-               , nng_ngrams_id  :: ngrams_id
-               , nng_parent_id  :: parent_id
-              
-               , nng_ngramsType :: ngrams_type
-               , nng_listType   :: list_type
-               , nng_weight     :: weight
-               } deriving (Show)
-
-type NodeNgramWrite =
-     NodeNgramPoly
-               (Column PGInt4  )
-               (Column PGInt4  )
-               (Maybe (Column PGInt4))
-               
-               (Column PGInt4  )
-               (Column PGInt4  )
-               (Column PGFloat8)
-
-type NodeNgramRead =
-     NodeNgramPoly
-       (Column PGInt4  )
-       (Column PGInt4  )
-       (Column PGInt4  )
-       
-       (Column PGInt4  )
-       (Column PGInt4  )
-       (Column PGFloat8)
-
-type NodeNgramReadNull =
-     NodeNgramPoly
-       (Column (Nullable PGInt4  ))
-       (Column (Nullable PGInt4  ))
-       (Column (Nullable PGInt4  ))
-       
-       (Column (Nullable PGInt4  ))
-       (Column (Nullable PGInt4  ))
-       (Column (Nullable PGFloat8))
-
-type NodeNgram =
-     NodeNgramPoly NodeId Int (Maybe NgramsParentId) NgramsTypeId Int Double
-
-newtype NgramsParentId = NgramsParentId Int
-  deriving (Show, Eq, Num)
-
-pgNgramsParentId :: NgramsParentId -> Column PGInt4
-pgNgramsParentId (NgramsParentId n) = pgInt4 n
-
-$(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
-makeLenses ''NodeNgramPoly
-
-nodeNgramTable :: Table NodeNgramWrite NodeNgramRead
-nodeNgramTable  = Table "nodes_ngrams"
-  ( pNodeNgram NodeNgram
-    { nng_node_id    = required "node_id"
-    , nng_ngrams_id  = required "ngrams_id"
-    , nng_parent_id  = optional "parent_id"
-    , nng_ngramsType = required "ngrams_type"
-    , nng_listType   = required "list_type"
-    , nng_weight     = required "weight"
-    }
-  )
-
-queryNodeNgramTable :: Query NodeNgramRead
-queryNodeNgramTable = queryTable nodeNgramTable
-
---{-
-insertNodeNgrams :: [NodeNgram] -> Cmd err Int
-insertNodeNgrams = insertNodeNgramW
-                 . map (\(NodeNgram n g p ngt lt w) ->
-                          NodeNgram (pgNodeId n)
-                                    (pgInt4 g)
-                                    (pgNgramsParentId <$> p)
-                                    (pgNgramsTypeId ngt)
-                                    (pgInt4 lt)
-                                    (pgDouble w)
-                        )
-insertNodeNgramW :: [NodeNgramWrite] -> Cmd err Int
-insertNodeNgramW nns =
-  mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
-    where
-      insertNothing = (Insert { iTable = nodeNgramTable
-                              , iRows  = nns
-                              , iReturning = rCount
-                              , iOnConflict = (Just DoNothing)
-                              })
---}
-type NgramsText = Text
-
-updateNodeNgrams' :: ListId -> [(NgramsTypeId, NgramsText, ListTypeId)] -> Cmd err ()
-updateNodeNgrams' _      []    = pure ()
-updateNodeNgrams' listId input = void $ execPGSQuery updateQuery (DPS.Only $ Values fields input')
-  where
-    fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"]
-    input' = map (\(nt,t,lt) -> (listId, nt, t, lt)) input
-
-updateNodeNgrams'_debug :: ListId -> [(NgramsTypeId, NgramsText, ListTypeId)] -> Cmd err ByteString
-updateNodeNgrams'_debug listId input = formatPGSQuery updateQuery (DPS.Only $ Values fields input')
-  where
-    fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"]
-    input' = map (\(nt,t,lt) -> (listId, nt, t, lt)) input
-
-updateQuery :: DPS.Query
-updateQuery = [sql|
-WITH new(node_id,ngrams_type,terms,typeList) as (?)
-
-INSERT into nodes_ngrams (node_id,ngrams_id,ngrams_type,list_type,weight)
-
-SELECT node_id,ngrams.id,ngrams_type,typeList,1 FROM new
-JOIN ngrams ON ngrams.terms = new.terms
-ON CONFLICT (node_id, ngrams_id, ngrams_type) DO
--- DO NOTHING
-
-UPDATE SET list_type = excluded.list_type
-;
-               |]

src/Gargantext/Database/Schema/NodeNode.hs

@@ -25,11 +25,11 @@ commentary with @some markup@.
 
 module Gargantext.Database.Schema.NodeNode where
 
-import Control.Lens (view)
+import Control.Lens (view, (^.))
 import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
 import Database.PostgreSQL.Simple.SqlQQ (sql)
-import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Control.Lens.TH (makeLenses)
 import Data.Maybe (Maybe, catMaybes)
 import Data.Text (Text, splitOn)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
@@ -44,10 +44,10 @@ import Control.Arrow (returnA)
 import qualified Opaleye as O
 
 data NodeNodePoly node1_id node2_id score cat
-                   = NodeNode { nn_node1_id   :: node1_id
-                              , nn_node2_id   :: node2_id
-                              , nn_score      :: score
-                              , nn_category   :: cat
+                   = NodeNode { _nn_node1_id   :: node1_id
+                              , _nn_node2_id   :: node2_id
+                              , _nn_score      :: score
+                              , _nn_category   :: cat
                               } deriving (Show)
 
 type NodeNodeWrite     = NodeNodePoly (Column (PGInt4))
@@ -59,7 +59,7 @@ type NodeNodeRead      = NodeNodePoly (Column (PGInt4))
                                       (Column (PGInt4))
                                       (Column (PGFloat8))
                                       (Column (PGInt4))
-                                      
+
 type NodeNodeReadNull  = NodeNodePoly (Column (Nullable PGInt4))
                                       (Column (Nullable PGInt4))
                                       (Column (Nullable PGFloat8))
@@ -68,14 +68,14 @@ type NodeNodeReadNull  = NodeNodePoly (Column (Nullable PGInt4))
 type NodeNode = NodeNodePoly Int Int (Maybe Double) (Maybe Int)
 
 $(makeAdaptorAndInstance "pNodeNode" ''NodeNodePoly)
-$(makeLensesWith abbreviatedFields   ''NodeNodePoly)
+makeLenses ''NodeNodePoly
 
 nodeNodeTable :: Table NodeNodeWrite NodeNodeRead
 nodeNodeTable  = Table "nodes_nodes" (pNodeNode
-                                NodeNode { nn_node1_id = required "node1_id"
-                                         , nn_node2_id = required "node2_id"
-                                         , nn_score    = optional "score"
-                                         , nn_category = optional "category"
+                                NodeNode { _nn_node1_id = required "node1_id"
+                                         , _nn_node2_id = required "node2_id"
+                                         , _nn_score    = optional "score"
+                                         , _nn_category = optional "category"
                                      }
                                      )
 
@@ -144,9 +144,9 @@ selectDocs cId = runOpaQuery (queryDocs cId)
 queryDocs :: CorpusId -> O.Query (Column PGJsonb)
 queryDocs cId = proc () -> do
   (n, nn) <- joinInCorpus -< ()
-  restrict -< ( nn_node1_id nn)  .== (toNullable $ pgNodeId cId)
-  restrict -< ( nn_category nn)  .>= (toNullable $ pgInt4 1)
-  restrict -< (_node_typename n) .== (pgInt4 $ nodeTypeId NodeDocument)
+  restrict -< nn^.nn_node1_id  .== (toNullable $ pgNodeId cId)
+  restrict -< nn^.nn_category  .>= (toNullable $ pgInt4 1)
+  restrict -< n^.node_typename .== (pgInt4 $ nodeTypeId NodeDocument)
   returnA -< view (node_hyperdata) n
 
 
@@ -156,9 +156,9 @@ selectDocNodes cId = runOpaQuery (queryDocNodes cId)
 queryDocNodes :: CorpusId -> O.Query NodeRead
 queryDocNodes cId = proc () -> do
   (n, nn) <- joinInCorpus -< ()
-  restrict -< ( nn_node1_id nn)  .== (toNullable $ pgNodeId cId)
-  restrict -< ( nn_category nn)  .>= (toNullable $ pgInt4 1)
-  restrict -< (_node_typename n) .== (pgInt4 $ nodeTypeId NodeDocument)
+  restrict -< nn^.nn_node1_id  .== (toNullable $ pgNodeId cId)
+  restrict -< nn^.nn_category  .>= (toNullable $ pgInt4 1)
+  restrict -< n^.node_typename .== (pgInt4 $ nodeTypeId NodeDocument)
   returnA -<  n
 
 
@@ -166,7 +166,7 @@ joinInCorpus :: O.Query (NodeRead, NodeNodeReadNull)
 joinInCorpus = leftJoin queryNodeTable queryNodeNodeTable cond
   where
     cond :: (NodeRead, NodeNodeRead) -> Column PGBool
-    cond (n, nn) = nn_node2_id nn .== (view node_id n)
+    cond (n, nn) = nn^.nn_node2_id .== (view node_id n)
 
 
 ------------------------------------------------------------------------

src/Gargantext/Database/Schema/NodeNodeNgrams.hs

@@ -25,7 +25,7 @@ module Gargantext.Database.Schema.NodeNodeNgrams
 import Prelude
 import Data.Maybe (Maybe)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
---import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Control.Lens.TH (makeLenses)
 import Gargantext.Database.Utils (Cmd, mkCmd)
 import Gargantext.Database.Schema.Ngrams (NgramsTypeId, pgNgramsTypeId, NgramsId)
 import Gargantext.Database.Schema.Node (pgNodeId)
@@ -35,12 +35,12 @@ import Opaleye
 
 
 data NodeNodeNgramsPoly id' n1 n2 ngrams_id ngt w
-   = NodeNodeNgrams { nnng_id         :: id'
-                    , nnng_node1_id   :: n1
-                    , nnng_node2_id   :: n2
-                    , nnng_ngrams_id  :: ngrams_id
-                    , nnng_ngramsType :: ngt
-                    , nnng_weight     :: w
+   = NodeNodeNgrams { _nnng_id         :: id'
+                    , _nnng_node1_id   :: n1
+                    , _nnng_node2_id   :: n2
+                    , _nnng_ngrams_id  :: ngrams_id
+                    , _nnng_ngramsType :: ngt
+                    , _nnng_weight     :: w
                     } deriving (Show)
 
 
@@ -71,19 +71,19 @@ type NodeNodeNgramsReadNull =
 type NodeNodeNgrams =
   NodeNodeNgramsPoly (Maybe Int) CorpusId DocId NgramsId NgramsTypeId Double
 
---{-
 $(makeAdaptorAndInstance "pNodeNodeNgrams" ''NodeNodeNgramsPoly)
--- $(makeLensesWith          abbreviatedFields ''NodeNodeNgramsPoly)
+makeLenses ''NodeNodeNgramsPoly
+
 
 nodeNodeNgramsTable :: Table NodeNodeNgramsWrite NodeNodeNgramsRead
 nodeNodeNgramsTable  = Table "node_node_ngrams"
                           ( pNodeNodeNgrams NodeNodeNgrams
-                               { nnng_id         = optional "id"
-                               , nnng_node1_id   = required "node1_id"
-                               , nnng_node2_id   = required "node2_id"
-                               , nnng_ngrams_id  = required "ngrams_id"
-                               , nnng_ngramsType = required "ngrams_type"
-                               , nnng_weight     = required "weight"
+                               { _nnng_id         = optional "id"
+                               , _nnng_node1_id   = required "node1_id"
+                               , _nnng_node2_id   = required "node2_id"
+                               , _nnng_ngrams_id  = required "ngrams_id"
+                               , _nnng_ngramsType = required "ngrams_type"
+                               , _nnng_weight     = required "weight"
                                }
                           )
 

src/Gargantext/Database/Tree.hs

@@ -16,7 +16,16 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE RankNTypes        #-}
 
-module Gargantext.Database.Tree (treeDB, TreeError(..), HasTreeError(..), dbTree, toNodeTree, DbTreeNode) where
+module Gargantext.Database.Tree
+  ( treeDB
+  , TreeError(..)
+  , HasTreeError(..)
+  , dbTree
+  , toNodeTree
+  , DbTreeNode
+  , isDescendantOf
+  , isIn
+  ) where
 
 import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
 import Control.Monad.Error.Class (MonadError(throwError))
@@ -27,7 +36,7 @@ import Database.PostgreSQL.Simple.SqlQQ
 
 import Gargantext.Prelude
 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
-import Gargantext.Database.Types.Node (NodeId)
+import Gargantext.Database.Types.Node (NodeId, DocId)
 import Gargantext.Database.Config (fromNodeTypeId)
 import Gargantext.Database.Utils (Cmd, runPGSQuery)
 ------------------------------------------------------------------------
@@ -84,26 +93,53 @@ data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
 -- | Main DB Tree function
 -- TODO add typenames as parameters
 dbTree :: RootId -> Cmd err [DbTreeNode]
-dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGSQuery [sql|
-  WITH RECURSIVE
-      tree (id, typename, parent_id, name) AS
+dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
+  <$> runPGSQuery [sql|
+    WITH RECURSIVE
+        tree (id, typename, parent_id, name) AS
+        (
+          SELECT p.id, p.typename, p.parent_id, p.name
+          FROM nodes AS p
+          WHERE p.id = ?
+
+          UNION
+
+          SELECT c.id, c.typename, c.parent_id, c.name
+          FROM nodes AS c
+
+          INNER JOIN tree AS s ON c.parent_id = s.id
+           WHERE c.typename IN (2,20,21,22,3,5,30,31,40,7,9,90)
+        )
+    SELECT * from tree;
+    |] (Only rootId)
+
+isDescendantOf :: NodeId -> RootId -> Cmd err Bool
+isDescendantOf childId rootId = (== [Only True])
+  <$> runPGSQuery [sql| WITH RECURSIVE
+      tree (id, parent_id) AS
       (
-        SELECT p.id, p.typename, p.parent_id, p.name
-        FROM nodes AS p
-        WHERE p.id = ?
-        
-        UNION
-        
-        SELECT c.id, c.typename, c.parent_id, c.name
+        SELECT c.id, c.parent_id
         FROM nodes AS c
-        
-        INNER JOIN tree AS s ON c.parent_id = s.id
-        WHERE c.typename IN (2,3,5,30,31,40,7,9,90)
-      )
-  SELECT * from tree;
-  |] (Only rootId)
+        WHERE c.id = ?
 
+        UNION
 
+        SELECT p.id, p.parent_id
+        FROM nodes AS p
+        INNER JOIN tree AS t ON t.parent_id = p.id
 
+      )
+  SELECT COUNT(*) = 1 from tree AS t
+  WHERE t.id = ?;
+  |] (childId, rootId)
+
+-- TODO should we check the category?
+isIn :: NodeId -> DocId -> Cmd err Bool
+isIn cId docId = ( == [Only True])
+  <$> runPGSQuery [sql| SELECT COUNT(*) = 1
+    FROM nodes_nodes nn
+      WHERE nn.node1_id = ?
+        AND nn.node2_id = ?;
+  |] (cId, docId)
 
 

src/Gargantext/Database/Triggers.hs

+{-|
+Module      : Gargantext.Database.Triggers
+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.Triggers
+  where
+
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+-- import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
+import Gargantext.Database.Config (nodeTypeId)
+import Gargantext.Database.Types.Node -- (ListId, CorpusId, NodeId)
+import Gargantext.Database.Utils (Cmd, runPGSQuery)
+import Gargantext.Prelude
+import qualified Database.PostgreSQL.Simple as DPS
+
+------------------------------------------------------------------------
+
+type MasterListId = ListId
+
+insertOccsUpdates :: UserCorpusId -> MasterListId -> Cmd err [DPS.Only Int]
+insertOccsUpdates cId lId = runPGSQuery query (cId, lId, nodeTypeId NodeList, nodeTypeId NodeDocument)
+  where
+    query :: DPS.Query
+    query = [sql|
+              INSERT INTO node_node_ngrams (node1_id, node2_id, ngrams_id, ngrams_type, weight)
+                SELECT nn.node1_id, lists.id, nnn.ngrams_id, 1, count(*) as c  -- type of score
+                   FROM node_node_ngrams nnn
+                   INNER JOIN nodes_nodes nn    ON nn.node2_id = nnn.node2_id
+                   INNER JOIN nodes       docs  ON docs.id     = nnn.node2_id
+                   INNER JOIN nodes       lists ON lists.parent_id = nn.node1_id
+                  -- WHERE nn.node1_id  = NEW.node1_id -- .node1_id -- corpus_id
+                  WHERE nn.node1_id  = ? -- .node1_id -- corpus_id
+                    AND nnn.node1_id in (?, lists.id)  -- (masterList_id, userLists)
+                    AND lists.typename = ?
+                    AND docs.typename  = ?
+                  GROUP BY nn.node1_id, lists.id, nnn.ngrams_id
+               ON CONFLICT (node1_id, node2_id, ngrams_id, ngrams_type)
+                  DO UPDATE SET weight = 3 -- c -- excluded.weight
+                  RETURNING 1
+                  -- TOCHECK
+  |]
+
+
+
+triggerOccsUpdates :: CorpusId -> ListId -> Cmd err [DPS.Only Int]
+triggerOccsUpdates cId lId = runPGSQuery query (cId, lId, nodeTypeId NodeList, nodeTypeId NodeDocument)
+  where
+    query :: DPS.Query
+    query = [sql|
+                drop trigger trigger_occs on nodes_nodes;
+                CREATE OR REPLACE FUNCTION occs_update() RETURNS trigger AS
+                  $$
+                      BEGIN
+                      IF TG_OP = 'UPDATE' THEN
+                      INSERT INTO node_node_ngrams (node1_id, node2_id, ngrams_id, ngrams_type, weight)
+                      -- TODO edge_type instead of ngrams_type
+                        SELECT nn.node1_id, lists.id, nnn.ngrams_id, count(*), 1  -- type of score
+                           FROM node_node_ngrams nnn
+                           INNER JOIN nodes_nodes nn    ON nn.node2_id = nnn.node2_id
+                           INNER JOIN nodes       docs  ON docs.id     = nnn.node2_id
+                           INNER JOIN nodes       lists ON lists.parent_id = nn.node1_id
+                          -- WHERE nn.node1_id  = NEW.node1_id -- .node1_id -- corpus_id
+                          WHERE nn.node1_id  = ? -- .node1_id -- corpus_id
+                            AND nnn.node1_id in (?, lists.id)  -- (masterList_id, userLists)
+                            AND lists.typename = ?
+                            AND docs.typename  = ?
+                          GROUP BY nn.node1_id, lists.id, nnn.ngrams_id
+                       ON CONFLICT (node1_id, node2_id, ngrams_id, ngrams_type)
+                          DO UPDATE SET weight = excluded.weight;
+                      END IF;
+                    RETURN NULL;
+                END $$
+                LANGUAGE plpgsql;
+
+                CREATE TRIGGER trigger_occs
+                  AFTER UPDATE ON nodes_nodes
+                  REFERENCING NEW TABLE AS NEW
+                  FOR EACH STATEMENT
+                  EXECUTE PROCEDURE occs_update();
+
+                update nodes_nodes SET node1_id = node1_id;
+  |]
+

src/Gargantext/Database/Utils.hs

@@ -30,6 +30,7 @@ import Control.Monad.Except
 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
 import Data.Either.Extra (Either(Left, Right))
 import Data.Ini (readIniFile, lookupValue)
+import qualified Data.List as DL
 import Data.Maybe (maybe)
 import Data.Monoid ((<>))
 import Data.Profunctor.Product.Default (Default)
@@ -41,6 +42,7 @@ import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(Conversion
 import Database.PostgreSQL.Simple.Internal  (Field)
 import Gargantext.Prelude
 import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
+import Opaleye.Aggregate (countRows)
 import System.IO (FilePath)
 import Text.Read (read)
 import qualified Data.ByteString      as DB
@@ -67,20 +69,30 @@ type Cmd' env err a = forall m. CmdM' env err m => m a
 
 type Cmd err a = forall m env. CmdM env err m => m a
 
+fromInt64ToInt :: Int64 -> Int
+fromInt64ToInt = fromIntegral
+
 -- TODO: ideally there should be very few calls to this functions.
 mkCmd :: (Connection -> IO a) -> Cmd err a
 mkCmd k = do
   conn <- view connection
   liftIO $ k conn
 
-runCmd :: (HasConnection env) => env
-       -> Cmd' env err a
+runCmd :: (HasConnection env)
+       => env -> Cmd' env err a
        -> IO (Either err a)
 runCmd env m = runExceptT $ runReaderT m env
 
-runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
+runOpaQuery :: Default FromFields fields haskells
+            => Select fields -> Cmd err [haskells]
 runOpaQuery q = mkCmd $ \c -> runQuery c q
 
+runCountOpaQuery :: Select a -> Cmd err Int
+runCountOpaQuery q = do
+  counts <- mkCmd $ \c -> runQuery c $ countRows q
+  -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
+  pure $ fromInt64ToInt $ DL.head counts
+
 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 

src/Gargantext/Text/Examples.hs

@@ -19,7 +19,6 @@ This document defines basic of Text definitions according to Gargantext..
 - What is a sentence ?
 - What is a paragraph ?
 
-
 -}
 
 {-# LANGUAGE BangPatterns      #-}
@@ -134,6 +133,7 @@ incExcSpeGen_sorted :: Ord t => Map (t,t) Int -> ([(t,Double)],[(t,Double)])
 incExcSpeGen_sorted m = both ordonne (incExcSpeGen $ cooc2mat ti m)
   where
     (ti,fi) = createIndices m
-    ordonne x = sortWith (Down . snd) $ zip (map snd $ M.toList fi) (toList x)
+    ordonne x = sortWith (Down . snd)
+              $ zip (map snd $ M.toList fi) (toList x)
 
 

src/Gargantext/Viz/Graph/FGL.hs

@@ -45,6 +45,24 @@ edges = FGL.edges
 nodes :: Graph gr => gr a b -> [Node]
 nodes = FGL.nodes
 
+------------------------------------------------------------------------
+-- | Graph Tools
+
+filterNeighbors :: Graph_Undirected -> Node -> [Node]
+filterNeighbors g n = List.nub $ neighbors g n
+
+-- Q: why not D.G.I.deg ? (Int as result)
+degree :: Graph_Undirected -> Node -> Double
+degree g n = fromIntegral $ List.length (filterNeighbors g n)
+
+vcount :: Graph_Undirected -> Double
+vcount = fromIntegral . List.length . List.nub . nodes
+
+-- | TODO tests, optim and use IGraph library, fix IO ?
+ecount :: Graph_Undirected -> Double
+ecount = fromIntegral . List.length . List.nub . edges
+
+
 ------------------------------------------------------------------
 -- | Main sugared functions
 

src/Gargantext/Viz/Phylo/Cluster.hs

@@ -53,7 +53,7 @@ relatedComp graphs = foldl' (\mem groups ->
 louvain :: ([GroupNode],[GroupEdge]) -> IO [[PhyloGroup]]
 louvain (nodes,edges) = map (\community -> map (\node -> nodes !! (l_node_id node)) community)
                       <$> groupBy (\a b -> (l_community_id a) == (l_community_id b))
-                      <$> (cLouvain $ mapKeys (\(x,y) -> (idx x, idx y)) $ fromList edges)
+                      <$> (cLouvain "0.0001" $ mapKeys (\(x,y) -> (idx x, idx y)) $ fromList edges)
   where
     -------------------------------------- 
     idx :: PhyloGroup -> Int