Merge branch 'master' into 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
+
+
+
+

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,

src/Gargantext/API/Ngrams.hs

@@ -130,7 +130,7 @@ import GHC.Generics (Generic)
 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)
@@ -1019,7 +1019,8 @@ getTableNgrams _nType nId tabType listId limit_ offset
     setScores True  table = do
       let ngrams_terms = (table ^.. each . ne_ngrams)
       t1 <- getTime'
-      occurrences <- getOccByNgramsOnlyFast nId
+      occurrences <- getOccByNgramsOnlyFast' nId
+                                             listId
                                             ngramsType
                                             ngrams_terms
       t2 <- getTime'
@@ -1153,8 +1154,6 @@ getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orde
 
 
 
-
-
 apiNgramsTableCorpus :: ( RepoCmdM env err m
                         , HasNodeError err
                         , HasInvalidError err

src/Gargantext/API/Node.hs

@@ -55,6 +55,7 @@ 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(..))
@@ -158,7 +159,8 @@ 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)

src/Gargantext/API/Table.hs

@@ -44,7 +44,7 @@ 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.Types (Offset, Limit, TableResult(..))
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..))
 import Gargantext.Database.Learn (FavOrTrash(..), moreLike)
@@ -60,7 +60,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
 type TableApi = Summary " Table API"
               :> ReqBody '[JSON] TableQuery
-              :> Post    '[JSON] TableResult
+              :> Post    '[JSON] FacetTableResult
 
 data TableQuery = TableQuery
   { tq_offset  :: Int
@@ -70,17 +70,7 @@ data TableQuery = TableQuery
   , tq_query  :: Text
   } deriving (Generic)
 
-data TableResult = TableResult { tr_count :: Int
-                               , tr_docs  :: [FacetDoc]
-                               } deriving (Generic)
-
-$(deriveJSON (unPrefix "tr_") ''TableResult)
-
-instance ToSchema TableResult where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "tr_")
-
-instance Arbitrary TableResult where
-  arbitrary = TableResult <$> arbitrary <*> arbitrary
+type FacetTableResult = TableResult FacetDoc
 
 $(deriveJSON (unPrefix "tq_") ''TableQuery)
 
@@ -91,7 +81,7 @@ instance Arbitrary TableQuery where
   arbitrary = elements [TableQuery 0 10 DateAsc Docs "electrodes"]
 
 
-tableApi :: NodeId -> TableQuery -> Cmd err TableResult
+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)
@@ -104,20 +94,21 @@ searchInCorpus' :: CorpusId
                 -> Maybe Offset
                 -> Maybe Limit
                 -> Maybe OrderBy
-                -> Cmd err TableResult
+                -> Cmd err FacetTableResult
 searchInCorpus' cId t q o l order = do
   docs <- searchInCorpus cId t q o l order
-  allDocs  <- searchInCorpus cId t q Nothing Nothing Nothing
-  pure (TableResult (length allDocs) docs)
+  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 TableResult
+         -> 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 (length allDocs) docs)
+  pure $ TableResult { tr_docs = docs, tr_count = length allDocs }
 
 getTable' :: NodeId -> Maybe TabType
          -> Maybe Offset  -> Maybe Limit

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

@@ -94,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/Flow.hs

@@ -67,6 +67,7 @@ import Gargantext.Database.Schema.User (getUser, UserLight(..))
 import Gargantext.Database.TextSearch (searchInDatabase)
 import Gargantext.Database.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
 import Gargantext.Database.Utils (Cmd, CmdM)
+import Gargantext.Database.Triggers
 import Gargantext.Ext.IMT (toSchoolName)
 import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
 import Gargantext.Prelude
@@ -223,14 +224,16 @@ flowCorpusUser l userName corpusName ctype ids = do
   -- TODO: check if present already, ignore
   _ <- Doc.add userCorpusId ids
   tId <- mkNode NodeTexts userCorpusId userId
-  
+
   printDebug "Node Text Id" tId
 
   -- User List Flow
   --{-
-  (_masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster (Left "") ctype
-  ngs         <- buildNgramsLists l 2 3 (StopSize 3) userCorpusId masterCorpusId
-  userListId  <- flowList userId userCorpusId ngs
+  (masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster (Left "") ctype
+  ngs        <- buildNgramsLists l 2 3 (StopSize 3) userCorpusId masterCorpusId
+  userListId <- flowList userId userCorpusId ngs
+  mastListId <- getOrMkList masterCorpusId masterUserId
+  _ <- insertOccsUpdates userCorpusId mastListId
   printDebug "userListId" userListId
   -- User Graph Flow
   _ <- mkDashboard userCorpusId userId

src/Gargantext/Database/Flow/Pairing.hs

@@ -32,16 +32,25 @@ 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.Flow.Utils
 import Gargantext.Database.Utils (Cmd, runPGSQuery)
-import Gargantext.Database.Types.Node (AnnuaireId, CorpusId, ListId)
+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
@@ -50,7 +59,7 @@ pairing :: AnnuaireId
 pairing aId cId lId = do
   contacts' <- getAllContacts aId
   let contactsMap = pairingPolicyToMap toLower
-                  $ toMaps extractNgramsT contacts'
+                  $ toMaps extractNgramsT (tr_docs contacts')
 
   ngramsMap' <- getNgramsTindexed cId Authors
   let ngramsMap = pairingPolicyToMap lastName ngramsMap'

src/Gargantext/Database/Flow/Utils.hs

@@ -25,12 +25,17 @@ import Gargantext.Database.Utils (Cmd)
 import Gargantext.Database.Schema.NodeNodeNgrams
 import Gargantext.Database.Types.Node
 
-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']
@@ -72,14 +77,17 @@ data DocNgrams = DocNgrams { dn_doc_id :: DocId
 insertDocNgramsOn :: CorpusId
                   -> [DocNgrams]
                   -> Cmd err Int
-insertDocNgramsOn cId dn = insertNodeNodeNgrams $ (map (docNgrams2nodeNodeNgrams cId) dn)
+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
-                                        ]
+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

@@ -28,10 +28,10 @@ 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
@@ -42,7 +42,7 @@ selectNgramsByDoc cIds dId nt = runOpaQuery (query cIds dId nt)
       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
+      returnA  -< ng^.ngrams_terms
 
 
 postNgrams :: CorpusId -> DocId -> [Text] -> Cmd err Int

src/Gargantext/Database/Node/Children.hs

@@ -30,12 +30,11 @@ import Gargantext.Database.Node.Contact (HyperdataContact)
 import Gargantext.Database.Schema.Node (pgNodeId)
 import Control.Arrow (returnA)
 
-
-getAllDocuments :: ParentId -> Cmd err [Node HyperdataDocument]
+getAllDocuments :: ParentId -> Cmd err (TableResult (Node HyperdataDocument))
 getAllDocuments pId = getAllChildren pId (Proxy :: Proxy HyperdataDocument)
                                          (Just NodeDocument)
 
-getAllContacts :: ParentId -> Cmd err [Node HyperdataContact]
+getAllContacts :: ParentId -> Cmd err (TableResult (Node HyperdataContact))
 getAllContacts pId = getAllChildren pId (Proxy :: Proxy HyperdataContact)
                                         (Just NodeContact)
 
@@ -43,7 +42,7 @@ getAllChildren :: JSONB a
                => ParentId
                -> proxy a
                -> Maybe NodeType
-               -> Cmd err [Node a]
+               -> Cmd err (NodeTableResult a)
 getAllChildren pId p maybeNodeType = getChildren pId p maybeNodeType Nothing Nothing
 
 getChildren :: JSONB a
@@ -52,11 +51,19 @@ getChildren :: JSONB 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
+            -> 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

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

@@ -373,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))
 
 

src/Gargantext/Database/TextSearch.hs

@@ -35,7 +35,7 @@ import Gargantext.Database.Schema.Ngrams
 import Gargantext.Database.Schema.NodeNode hiding (joinInCorpus)
 import Gargantext.Database.Schema.NodeNodeNgrams
 import Gargantext.Database.Queries.Join (leftJoin6)
-import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery)
+import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery, runCountOpaQuery)
 import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
 import Gargantext.Core.Types
 import Control.Arrow (returnA)
@@ -72,6 +72,15 @@ searchInCorpus cId t q o l order = runOpaQuery
                                  $ intercalate " | "
                                  $ map stemIt q
 
+searchCountInCorpus :: CorpusId
+                    -> IsTrash
+                    -> [Text]
+                    -> Cmd err Int
+searchCountInCorpus cId t q = runCountOpaQuery
+                            $ queryInCorpus cId t
+                            $ intercalate " | "
+                            $ map stemIt q
+
 queryInCorpus :: CorpusId
               -> IsTrash
               -> Text

src/Gargantext/Database/Tree.hs

@@ -108,7 +108,7 @@ dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
           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)
+           WHERE c.typename IN (2,20,21,22,3,5,30,31,40,7,9,90)
         )
     SELECT * from tree;
     |] (Only rootId)

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,6 +69,9 @@ 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
@@ -82,6 +87,12 @@ 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/Viz/Graph/Tools.hs

@@ -15,6 +15,7 @@ Portability : POSIX
 module Gargantext.Viz.Graph.Tools
   where
 
+import Debug.Trace (trace)
 import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
 import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
 import Data.Map (Map)
@@ -47,16 +48,39 @@ cooc2graph threshold myCooc = do
       distanceMat = measureConditional matCooc
       distanceMap = Map.filter (> threshold) $ mat2map distanceMat
 
+  let nodesApprox :: Int
+      nodesApprox = n'
+        where
+          (as, bs) = List.unzip $ Map.keys distanceMap
+          n' = Set.size $ Set.fromList $ as <> bs
+      ClustersParams rivers level = trace ("nodesApprox: " <> show nodesApprox) $ clustersParams nodesApprox
+
+
   partitions <- case Map.size distanceMap > 0 of
-    True  -> cLouvain distanceMap
+    True  -> trace ("level" <> show level) $ cLouvain level distanceMap
     False -> panic "Text.Flow: DistanceMap is empty"
 
-  let bridgeness' = bridgeness 300 partitions distanceMap
+  let bridgeness' = trace ("rivers: " <> show rivers) $ bridgeness rivers partitions distanceMap
   let confluence' = confluence (Map.keys bridgeness') 3 True False
 
   data2graph (Map.toList ti) myCooc' bridgeness' confluence' partitions
 
 
+
+data ClustersParams = ClustersParams { bridgness :: Double
+                                     , louvain   :: Text
+                                     } deriving (Show)
+
+clustersParams :: Int -> ClustersParams
+clustersParams x = ClustersParams (fromIntegral x) y
+  where
+    y | x < 100  = "0.0001"
+      | x < 350  = "0.001"
+      | x < 500  = "0.01"
+      | x < 1000 = "0.1"
+      | otherwise = "1"
+
+
 ----------------------------------------------------------
 -- | From data to Graph
 data2graph :: [(Text, Int)]

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

stack.yaml

@@ -4,6 +4,7 @@ extra-package-dbs: []
 packages:
 - .
 
+
 docker:
   enable: false
   repo: 'fpco/stack-build:lts-14.6-garg'
@@ -39,7 +40,7 @@ extra-deps:
 - git: https://github.com/np/servant-job.git
   commit: 8557bfc9472a1b2be0b7bc632c23701ba5f44bf8
 - git: https://gitlab.iscpif.fr/gargantext/clustering-louvain.git
-  commit: 1c636112b151110408e7c5a28cec39e46657358e
+  commit: b29040ce741629d61cc63e8ba97e75bf0944979e
 - git: https://github.com/np/patches-map
   commit: 8c6f38c4844ead53e664cf9c82ba461715dbe445
 - git: https://github.com/delanoe/haskell-opaleye.git  #- opaleye-0.6.7002.0