Merge branch 'dev-optim' into dev

bin/gargantext-import/Main.hs

@@ -28,7 +28,8 @@ import Gargantext.API.Node () -- instances
 import Gargantext.API.Prelude (GargError)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Types.Individu (User(..))
-import Gargantext.Database.Action.Flow (FlowCmdM, flowCorpusFile, flowAnnuaire, TermType(..))
+import Gargantext.Database.Action.Flow (flowCorpusFile, flowAnnuaire, TermType(..))
+import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Admin.Types.Hyperdata (toHyperdataDocument)
 import Gargantext.Database.Admin.Types.Node (CorpusId)
 import Gargantext.Database.Prelude (Cmd)
@@ -46,10 +47,10 @@ main = do
     tt = (Multi EN)
     format = CsvGargV3 -- CsvHal --WOS
     corpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
-    corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt  format corpusPath
+    corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt  format corpusPath Nothing
 
     corpusCsvHal :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
-    corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHal corpusPath
+    corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHal corpusPath Nothing
 
     annuaire :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
     annuaire = flowAnnuaire (UserName $ cs user) (Left "Annuaire") (Multi EN) corpusPath

bin/gargantext-upgrade/Main.hs

@@ -19,33 +19,37 @@ import Gargantext.API.Admin.EnvTypes (DevEnv)
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Prelude (GargError)
 import Gargantext.API.Node () -- instances only
+import Gargantext.API.Ngrams.Tools (getRepo)
 import Gargantext.Database.Prelude (Cmd'', )
+import Gargantext.Core.NodeStory
 import Gargantext.Prelude
+import Gargantext.Prelude.Config (GargConfig(..), readConfig)
 import System.Environment (getArgs)
 import Prelude (getLine)
-
--- PosTag
-import Gargantext.Database.Action.Flow (indexAllDocumentsWithPosTag)
+import GHC.IO.Exception (IOException)
 
 main :: IO ()
 main = do
-  [iniPath] <- getArgs
 
-  putStrLn "Manual method (for now):"
-  putStrLn "Upgrade your schema database with the script:"
-  putStrLn "psql gargandbV5 < ./devops/postgres/upgrade/0.0.2.6.sql"
-  putStrLn "Then press enter key when you are done"
+  putStrLn "Manual method:"
+  putStrLn "Upgrade your GarganText instance with the script:"
+  putStrLn "Then press enter key to launch upgrade."
   _ok  <- getLine
 
+  [iniPath] <- getArgs
+  cfg       <- readConfig         iniPath
+
   let
-    upgrade :: Cmd'' DevEnv GargError ()
+    -- upgrade :: Cmd'' DevEnv GargError ()
+    upgrade :: Cmd'' DevEnv IOException ()
     upgrade = do
-      -- This method does not work for now
-      -- _ <- createTable_NgramsPostag
-      _ <- indexAllDocumentsWithPosTag
+      let repo_filepath = _gc_repofilepath cfg
+      repo <- getRepo
+      _ <- liftBase $ repoMigration repo_filepath repo
       pure ()
+      
 
   withDevEnv iniPath $ \env -> do
     _ <- runCmdDev env upgrade
-    putStrLn "Uprade"
+    putStrLn "Uprade done with success"
   pure ()

package.yaml

@@ -43,18 +43,21 @@ library:
   - Gargantext.API.Node
   - Gargantext.API.Node.File
   - Gargantext.API.Ngrams
+  - Gargantext.API.Ngrams.Tools
   - Gargantext.API.Ngrams.Types
   - Gargantext.API.Admin.Settings
   - Gargantext.API.Admin.EnvTypes
   - Gargantext.API.Admin.Types
   - Gargantext.API.Prelude
   - Gargantext.Core
+  - Gargantext.Core.NodeStory
   - Gargantext.Core.Methods.Distances
   - Gargantext.Core.Types
   - Gargantext.Core.Types.Individu
   - Gargantext.Core.Types.Main
   - Gargantext.Core.Utils.Prefix
   - Gargantext.Database.Action.Flow
+  - Gargantext.Database.Action.Flow.Types
   - Gargantext.Database.Action.User.New
   - Gargantext.Database.Query.Table.User
   - Gargantext.Database.Query.Table.Node
@@ -120,6 +123,7 @@ library:
   - case-insensitive
   - cassava
   - cereal     # (IGraph)
+  - cborg
   - conduit
   - conduit-extra
   - containers

src/Gargantext/API.hs

@@ -28,36 +28,34 @@ Pouillard (who mainly made it).
 
 {-# LANGUAGE ScopedTypeVariables  #-}
 
----------------------------------------------------------------------
 module Gargantext.API
       where
----------------------------------------------------------------------
+
 import Control.Exception (finally)
 import Control.Lens
 import Control.Monad.Reader (runReaderT)
 import Data.List (lookup)
 import Data.Text.Encoding (encodeUtf8)
+import Data.Text.IO (putStrLn)
 import Data.Validity
 import GHC.Base (Applicative)
 import GHC.Generics (Generic)
-import Network.HTTP.Types hiding (Query)
-import Network.Wai
-import Network.Wai.Handler.Warp hiding (defaultSettings)
-import Network.Wai.Middleware.Cors
-import Network.Wai.Middleware.RequestLogger
-import Servant
-import System.IO (FilePath)
-import Data.Text.IO (putStrLn)
-
 import Gargantext.API.Admin.Auth.Types (AuthContext)
 import Gargantext.API.Admin.Settings (newEnv)
 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
-import Gargantext.API.Ngrams (saveRepo)
-import Gargantext.API.Ngrams.Types (HasRepoSaver(..))
+import Gargantext.API.Ngrams (saveNodeStory)
 import Gargantext.API.Prelude
 import Gargantext.API.Routes
 import Gargantext.API.Server (server)
+import Gargantext.Core.NodeStory
 import Gargantext.Prelude hiding (putStrLn)
+import Network.HTTP.Types hiding (Query)
+import Network.Wai
+import Network.Wai.Handler.Warp hiding (defaultSettings)
+import Network.Wai.Middleware.Cors
+import Network.Wai.Middleware.RequestLogger
+import Servant
+import System.IO (FilePath)
 
 
 data Mode = Dev | Mock | Prod 
@@ -79,10 +77,10 @@ portRouteInfo port = do
   putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 
 -- TODO clean this Monad condition (more generic) ?
-stopGargantext :: HasRepoSaver env => env -> IO ()
+stopGargantext :: HasNodeStorySaver env => env -> IO ()
 stopGargantext env = do
   putStrLn "----- Stopping gargantext -----"
-  runReaderT saveRepo env
+  runReaderT saveNodeStory env
 
 {-
 startGargantextMock :: PortNumber -> IO ()
@@ -226,4 +224,4 @@ type family GenericTypeName t (r :: *) :: Symbol where
     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 
 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
--}
\ No newline at end of file
+-}

src/Gargantext/API/Admin/EnvTypes.hs

@@ -14,23 +14,24 @@ import Servant.Job.Async (HasJobEnv(..), Job)
 import System.Log.FastLogger
 import qualified Servant.Job.Core
 
+import Gargantext.API.Ngrams.Types (HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..))
 import Gargantext.API.Admin.Types
 import Gargantext.API.Admin.Orchestrator.Types
-import Gargantext.API.Ngrams.Types (HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..))
 import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(..))
-
+import Gargantext.Core.NodeStory
 
 data Env = Env
-  { _env_settings :: !Settings
-  , _env_logger   :: !LoggerSet
-  , _env_pool     :: !(Pool Connection)
-  , _env_repo     :: !RepoEnv
-  , _env_manager  :: !Manager
-  , _env_self_url :: !BaseUrl
-  , _env_scrapers :: !ScrapersEnv
-  , _env_config   :: !GargConfig
+  { _env_settings  :: !Settings
+  , _env_logger    :: !LoggerSet
+  , _env_pool      :: !(Pool Connection)
+  , _env_repo      :: !RepoEnv
+  , _env_nodeStory :: !NodeStoryEnv
+  , _env_manager   :: !Manager
+  , _env_self_url  :: !BaseUrl
+  , _env_scrapers  :: !ScrapersEnv
+  , _env_config    :: !GargConfig
   }
   deriving (Generic)
 
@@ -42,17 +43,28 @@ instance HasConfig Env where
 instance HasConnectionPool Env where
   connPool = env_pool
 
+instance HasNodeStoryEnv Env where
+  hasNodeStory = env_nodeStory
+
+instance HasNodeStoryVar Env where
+  hasNodeStoryVar = hasNodeStory . nse_getter
+
+instance HasNodeStorySaver Env where
+  hasNodeStorySaver = hasNodeStory . nse_saver
+
+instance HasSettings Env where
+  settings = env_settings
+
+-- Specific to Repo
 instance HasRepoVar Env where
   repoVar = repoEnv . repoVar
-
 instance HasRepoSaver Env where
   repoSaver = repoEnv . repoSaver
-
 instance HasRepo Env where
   repoEnv = env_repo
 
-instance HasSettings Env where
-  settings = env_settings
+
+
 
 instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
   _env = env_scrapers . Servant.Job.Core._env
@@ -68,11 +80,13 @@ data MockEnv = MockEnv
 makeLenses ''MockEnv
 
 
+
 data DevEnv = DevEnv
-  { _dev_env_pool     :: !(Pool Connection)
-  , _dev_env_repo     :: !RepoEnv
-  , _dev_env_settings :: !Settings
-  , _dev_env_config   :: !GargConfig
+  { _dev_env_settings  :: !Settings
+  , _dev_env_repo      :: !RepoEnv
+  , _dev_env_config    :: !GargConfig
+  , _dev_env_pool      :: !(Pool Connection)
+  , _dev_env_nodeStory :: !NodeStoryEnv
   }
 
 makeLenses ''DevEnv
@@ -83,14 +97,25 @@ instance HasConfig DevEnv where
 instance HasConnectionPool DevEnv where
   connPool = dev_env_pool
 
+instance HasSettings DevEnv where
+  settings = dev_env_settings
+
+
+instance HasNodeStoryEnv DevEnv where
+  hasNodeStory = dev_env_nodeStory
+
+instance HasNodeStoryVar DevEnv where
+  hasNodeStoryVar = hasNodeStory . nse_getter
+
+instance HasNodeStorySaver DevEnv where
+  hasNodeStorySaver = hasNodeStory . nse_saver
+
+
 instance HasRepoVar DevEnv where
   repoVar = repoEnv . repoVar
-
 instance HasRepoSaver DevEnv where
   repoSaver = repoEnv . repoSaver
-
 instance HasRepo DevEnv where
   repoEnv = dev_env_repo
 
-instance HasSettings DevEnv where
-  settings = dev_env_settings
+

src/Gargantext/API/Admin/Settings.hs

@@ -27,6 +27,8 @@ import Control.Monad.Reader
 import Data.Maybe (fromMaybe)
 import Data.Pool (Pool, createPool)
 import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
+import Gargantext.Core.NodeStory
+import Gargantext.Prelude.Config (GargConfig(..), {-gc_repofilepath,-} readConfig)
 import Network.HTTP.Client.TLS (newTlsManager)
 import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, readKey, writeKey)
 import Servant.Client (parseBaseUrl)
@@ -38,12 +40,13 @@ import System.IO.Temp (withTempFile)
 import System.Log.FastLogger
 import qualified Data.ByteString.Lazy as L
 
+
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Types
 import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
 import Gargantext.Database.Prelude (databaseParameters, HasConfig(..))
 import Gargantext.Prelude
-import Gargantext.Prelude.Config (GargConfig(..), gc_repofilepath, readConfig)
+import Gargantext.Prelude.Config (gc_repofilepath)
 
 devSettings :: FilePath -> IO Settings
 devSettings jwkFile = do
@@ -97,16 +100,20 @@ type RepoDirFilePath = FilePath
 repoSnapshot :: RepoDirFilePath -> FilePath
 repoSnapshot repoDir = repoDir <> "/repo.cbor"
 
--- | TODO add hard coded file in Settings
+
+
 -- This assumes we own the lock on repoSnapshot.
 repoSaverAction :: RepoDirFilePath -> Serialise a => a -> IO ()
 repoSaverAction repoDir a = do
-  withTempFile "repos" "tmp-repo.cbor" $ \fp h -> do
+  withTempFile repoDir "tmp-repo.cbor" $ \fp h -> do
     printDebug "repoSaverAction" fp
     L.hPut h $ serialise a
     hClose h
     renameFile fp (repoSnapshot repoDir)
 
+
+
+--{-
 -- The use of mkDebounce makes sure that repoSaverAction is not called too often.
 -- If repoSaverAction start taking more time than the debounceFreq then it should
 -- be increased.
@@ -155,43 +162,46 @@ readRepoEnv repoDir = do
   -- TODO save in DB here
   saver <- mkRepoSaver repoDir 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
+  manager_env  <- newTlsManager
   settings'    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
   when (port /= settings' ^. appPort) $
     panic "TODO: conflicting settings of port"
 
-  config'      <- readConfig file
-  self_url     <- parseBaseUrl $ "http://0.0.0.0:" <> show port
-  dbParam      <- databaseParameters file
-  pool         <- newPool dbParam
-  repo         <- readRepoEnv (_gc_repofilepath config')
-  scrapers_env <- newJobEnv defaultSettings manager
-  logger       <- newStderrLoggerSet defaultBufSize
+  config_env    <- readConfig file
+  self_url_env  <- parseBaseUrl $ "http://0.0.0.0:" <> show port
+  dbParam       <- databaseParameters file
+  pool          <- newPool dbParam
+  repo          <- readRepoEnv (_gc_repofilepath config_env)
+  nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
+  scrapers_env  <- newJobEnv defaultSettings manager_env
+  logger        <- newStderrLoggerSet defaultBufSize
 
   pure $ Env
-    { _env_settings = settings'
-    , _env_logger   = logger
-    , _env_pool     = pool
-    , _env_repo     = repo
-    , _env_manager  = manager
-    , _env_scrapers = scrapers_env
-    , _env_self_url = self_url
-    , _env_config   = config'
+    { _env_settings  = settings'
+    , _env_logger    = logger
+    , _env_pool      = pool
+    , _env_repo      = repo
+    , _env_nodeStory = nodeStory_env
+    , _env_manager   = manager_env
+    , _env_scrapers  = scrapers_env
+    , _env_self_url  = self_url_env
+    , _env_config    = config_env
     }
 
 newPool :: ConnectInfo -> IO (Pool Connection)
 newPool param = createPool (connect param) close 1 (60*60) 8
 
+--{-
 cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
 cleanEnv env = do
   r <- takeMVar (env ^. repoEnv . renv_var)
   repoSaverAction (env ^. hasConfig . gc_repofilepath) r
   unlockFile (env ^. repoEnv . renv_lock)
-
-type IniPath  = FilePath
+--}

src/Gargantext/API/Admin/Types.hs

@@ -9,10 +9,10 @@ import Control.Monad.Logger
 import Data.ByteString (ByteString)
 import GHC.Enum
 import GHC.Generics (Generic)
+import Gargantext.Prelude
 import Servant.Auth.Server (JWTSettings, CookieSettings(..))
 import Servant.Client (BaseUrl)
 
-import Gargantext.Prelude
 
 type PortNumber = Int
 
@@ -42,4 +42,4 @@ class HasSettings env where
 instance HasSettings Settings where
   settings = identity
 
-data FireWall = FireWall { unFireWall :: Bool }
\ No newline at end of file
+data FireWall = FireWall { unFireWall :: Bool }

src/Gargantext/API/Dev.hs

@@ -15,16 +15,18 @@ module Gargantext.API.Dev where
 import Control.Exception (finally)
 import Control.Monad (fail)
 import Control.Monad.Reader (runReaderT)
-import Servant
-
-import Gargantext.API.Prelude
-import Gargantext.API.Admin.Settings
 import Gargantext.API.Admin.EnvTypes
-import Gargantext.API.Ngrams (saveRepo)
+import Gargantext.API.Admin.Settings
+import Gargantext.API.Ngrams (saveNodeStory)
+import Gargantext.API.Prelude
+import Gargantext.Core.NodeStory
 import Gargantext.Database.Prelude
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(..), readConfig)
+import Servant
+import System.IO (FilePath)
 
+type IniPath  = FilePath
 -------------------------------------------------------------------
 withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
 withDevEnv iniPath k = do
@@ -35,12 +37,14 @@ withDevEnv iniPath k = do
     newDevEnv = do
       cfg     <- readConfig         iniPath
       dbParam <- databaseParameters iniPath
+      nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
       pool    <- newPool            dbParam
       repo    <- readRepoEnv        (_gc_repofilepath cfg)
       setts   <- devSettings devJwkFile
       pure $ DevEnv
         { _dev_env_pool     = pool
         , _dev_env_repo     = repo
+        , _dev_env_nodeStory  = nodeStory_env
         , _dev_env_settings = setts
         , _dev_env_config   = cfg
         }
@@ -56,11 +60,11 @@ runCmdReplServantErr = runCmdRepl
 -- the command.
 -- This function is constrained to the DevEnv rather than
 -- using HasConnectionPool and HasRepoVar.
-runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
+runCmdDev :: (Show err) => DevEnv -> Cmd'' DevEnv err a -> IO a
 runCmdDev env f =
   (either (fail . show) pure =<< runCmd env f)
     `finally`
-  runReaderT saveRepo env
+  runReaderT saveNodeStory env
 
 runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
 runCmdDevNoErr = runCmdDev

src/Gargantext/API/Metrics.hs

@@ -30,10 +30,10 @@ import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeL
 import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
 import Gargantext.Core.Viz.Chart
 import Gargantext.Core.Viz.Types
-import Gargantext.Database.Action.Flow
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..), hl_chart, hl_pie, hl_scatter, hl_tree)
 import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
 import Gargantext.Database.Admin.Types.Node (NodeId)
+import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)

src/Gargantext/API/Ngrams/List.hs

@@ -9,7 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE MonoLocalBinds #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeOperators     #-}
 
@@ -18,33 +17,20 @@ module Gargantext.API.Ngrams.List
 
 import Control.Lens hiding (elements, Indexed)
 import Data.Aeson
-import qualified Data.ByteString.Lazy as BSL
-import qualified Data.Csv as Csv
 import Data.Either (Either(..))
 import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import qualified Data.List           as List
 import Data.Map (Map, toList, fromList)
-import qualified Data.Map            as Map
 import Data.Maybe (catMaybes)
 import Data.Set (Set)
 import Data.Text (Text, concat, pack)
-import qualified Data.Text           as Text
 import Data.Vector (Vector)
-import qualified Data.Vector as Vec
-import Network.HTTP.Media ((//), (/:))
-import qualified Prelude as Prelude
-import Servant
-import Servant.Job.Async
-
-import qualified Protolude as P
-
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Ngrams (getNgramsTableMap, setListNgrams)
-import Gargantext.API.Ngrams.List.Types
 import Gargantext.API.Ngrams.Tools (getTermsWith)
 import Gargantext.API.Ngrams.Types
+import Gargantext.API.Ngrams.List.Types
 import Gargantext.API.Prelude (GargServer)
+import Gargantext.Core.NodeStory
 import Gargantext.Core.Text.Terms (ExtractedNgrams(..))
 import Gargantext.Core.Text.Terms.WithList (buildPatterns, termsInText)
 import Gargantext.Core.Types.Main (ListType(..))
@@ -58,20 +44,29 @@ import Gargantext.Database.Schema.Ngrams
 import Gargantext.Database.Schema.Node
 import Gargantext.Database.Types (Indexed(..))
 import Gargantext.Prelude
-
+import Network.HTTP.Media ((//), (/:))
+import Servant
+import Servant.Job.Async
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Csv as Csv
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.List           as List
+import qualified Data.Map            as Map
+import qualified Data.Text           as Text
+import qualified Data.Vector         as Vec
+import qualified Prelude             as Prelude
+import qualified Protolude           as P
 ------------------------------------------------------------------------
-{-
 -- | TODO refactor 
+{-
 type API =  Get '[JSON, HTML] (Headers '[Header "Content-Disposition" Text] NgramsList)
        -- :<|> ReqBody '[JSON] NgramsList :> Post '[JSON] Bool
        :<|> PostAPI
        :<|> CSVPostAPI
-
 api :: ListId -> GargServer API
 api l = get l :<|> postAsync l :<|> csvPostAsync l
 -}
 
-
 ----------------------
 type GETAPI = Summary "Get List"
             :> "lists"
@@ -86,7 +81,6 @@ instance Accept HTML where
 instance ToJSON a => MimeRender HTML a where
   mimeRender _ = encode
 
-
 ----------------------
 type JSONAPI = Summary "Update List"
           :> "lists"
@@ -112,12 +106,8 @@ type CSVAPI = Summary "Update List (legacy v3 CSV)"
 csvApi :: GargServer CSVAPI
 csvApi = csvPostAsync
 
-----------------------
-
-
-
 ------------------------------------------------------------------------
-get :: RepoCmdM env err m =>
+get :: HasNodeStory env err m =>
        ListId -> m (Headers '[Header "Content-Disposition" Text] NgramsList)
 get lId = do
   lst <- get' lId
@@ -128,7 +118,7 @@ get lId = do
                              ]
                      ) lst
 
-get' :: RepoCmdM env err m
+get' :: HasNodeStory env err m
     => ListId -> m NgramsList
 get' lId = fromList
        <$> zip ngramsTypes
@@ -148,11 +138,10 @@ post l m  = do
   -- TODO reindex
   pure True
 
-
------------------------------------------------------------------------------
+------------------------------------------------------------------------
 -- | Re-index documents of a corpus with new ngrams (called orphans here)
-reIndexWith :: ( HasRepo env
-               , FlowCmdM env err m
+reIndexWith :: ( HasNodeStory env err m
+               , FlowCmdM     env err m
                )
             => CorpusId
             -> ListId
@@ -252,6 +241,14 @@ postAsync' l (WithFile _ m _) logStatus = do
               , _scst_events    = Just []
               }
 ------------------------------------------------------------------------
+
+type CSVPostAPI = Summary "Update List (legacy v3 CSV)"
+        :> "csv"
+        :> "add"
+        :> "form"
+        :> "async"
+        :> AsyncJobs JobLog '[FormUrlEncoded] WithFile JobLog
+
 readCsvText :: Text -> [(Text, Text, Text)]
 readCsvText t = case eDec of
   Left _ -> []
@@ -300,6 +297,7 @@ csvPostAsync lId =
             liftBase $ log' x
       csvPostAsync' lId f log''
 
+
 csvPostAsync' :: FlowCmdM env err m
              => ListId
              -> WithTextFile
@@ -318,5 +316,4 @@ csvPostAsync' l (WithTextFile _ m _) logStatus = do
               , _scst_remaining = Just 0
               , _scst_events    = Just []
               }
-
 ------------------------------------------------------------------------

src/Gargantext/API/Ngrams/Tools.hs

@@ -28,60 +28,102 @@ import Gargantext.Prelude
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Map.Strict     as Map
 import qualified Data.Set            as Set
+import Gargantext.Core.NodeStory
 
 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
 mergeNgramsElement _neOld neNew = neNew
 
 type RootTerm = NgramsTerm
 
+
 getRepo :: RepoCmdM env err m => m NgramsRepo
 getRepo = do
   v <- view repoVar
   liftBase $ readMVar v
 
-listNgramsFromRepo :: [ListId] -> NgramsType
-                   -> NgramsRepo -> HashMap NgramsTerm NgramsRepoElement
-listNgramsFromRepo nodeIds ngramsType repo = ngrams
-  where
-    ngramsMap = repo ^. r_state . at ngramsType . _Just
 
-    -- TODO HashMap linked
-    ngrams    = HM.fromList $ Map.toList $ Map.unionsWith mergeNgramsElement
-                [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
+getRepo' :: HasNodeStory env err m
+         => [ListId] -> m NodeListStory
+getRepo' listIds = do
+  f <- getNodeListStory
+  v  <- liftBase $ f listIds
+  v' <- liftBase $ readMVar v
+  pure $ v'
+
+
+getNodeStoryVar :: HasNodeStory env err m
+           => [ListId] -> m (MVar NodeListStory)
+getNodeStoryVar l = do
+  f <- getNodeListStory
+  v  <- liftBase $ f l
+  pure v
+
+
+getNodeListStory :: HasNodeStory env err m
+                 => m ([NodeId] -> IO (MVar NodeListStory))
+getNodeListStory = do
+  env <- view hasNodeStory
+  pure $ view nse_getter env
+
+
+
+listNgramsFromRepo :: [ListId]
+                   -> NgramsType
+                   -> NodeListStory
+                   -> HashMap NgramsTerm NgramsRepoElement
+listNgramsFromRepo nodeIds ngramsType repo =
+  HM.fromList $ Map.toList
+              $ Map.unionsWith mergeNgramsElement ngrams
+    where
+      ngrams = [ repo
+               ^. unNodeStory
+                . at nodeId . _Just
+                . a_state
+                . at ngramsType . _Just
+                | nodeId <- nodeIds
+                ]
+
 
 
 -- 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
+getListNgrams :: HasNodeStory env err m
               => [ListId] -> NgramsType
               -> m (HashMap NgramsTerm NgramsRepoElement)
-getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
+getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType
+                                 <$> getRepo' nodeIds
 
-getTermsWith :: (RepoCmdM env err m, Eq a, Hashable a)
+
+getTermsWith :: (HasNodeStory env err m, Eq a, Hashable a)
           => (NgramsTerm -> a) -> [ListId]
           -> NgramsType -> Set ListType
           -> m (HashMap a [a])
-getTermsWith f ls ngt lts = HM.fromListWith (<>)
+getTermsWith f ls ngt lts  = HM.fromListWith (<>)
                       <$> map toTreeWith
                       <$> HM.toList
                       <$> HM.filter (\f' -> Set.member (fst f') lts)
                       <$> mapTermListRoot ls ngt
-                      <$> getRepo
+                      <$> getRepo' ls
   where
     toTreeWith (t, (_lt, maybeRoot)) = case maybeRoot of
       Nothing -> (f t, [])
       Just  r -> (f r, [f t])
 
+
+
 mapTermListRoot :: [ListId]
                 -> NgramsType
-                -> NgramsRepo
+                -> NodeListStory
                 -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
 mapTermListRoot nodeIds ngramsType repo =
       (\nre -> (_nre_list nre, _nre_root nre))
   <$> listNgramsFromRepo nodeIds ngramsType repo
 
+
+
+
 filterListWithRootHashMap :: ListType
                           -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
                           -> HashMap NgramsTerm (Maybe RootTerm)
@@ -122,11 +164,17 @@ groupNodesByNgrams syn occs = HM.fromListWith (<>) occs'
 
 data Diagonal = Diagonal Bool
 
-getCoocByNgrams :: Diagonal -> HashMap NgramsTerm (Set NodeId) -> HashMap (NgramsTerm, NgramsTerm) Int
+getCoocByNgrams :: Diagonal
+                -> HashMap NgramsTerm (Set NodeId)
+                -> HashMap (NgramsTerm, NgramsTerm) Int
 getCoocByNgrams = getCoocByNgrams' identity
 
 
-getCoocByNgrams' :: (Hashable a, Ord a, Ord c) => (b -> Set c) -> Diagonal -> HashMap a b -> HashMap (a, a) Int
+getCoocByNgrams' :: (Hashable a, Ord a, Ord c)
+                 => (b -> Set c)
+                 -> Diagonal
+                 -> HashMap a b
+                 -> HashMap (a, a) Int
 getCoocByNgrams' f (Diagonal diag) m =
   HM.fromList [( (t1,t2)
                , maybe 0 Set.size $ Set.intersection

src/Gargantext/API/Ngrams/Types.hs

@@ -12,8 +12,7 @@ module Gargantext.API.Ngrams.Types where
 import Codec.Serialise (Serialise())
 import Control.Category ((>>>))
 import Control.Concurrent
-import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~))
-import Control.Monad.Reader
+import Control.Lens (makeLenses, makePrisms, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~), Getter)
 import Control.Monad.State
 import Data.Aeson hiding ((.=))
 import Data.Aeson.TH (deriveJSON)
@@ -23,7 +22,7 @@ import Data.Hashable (Hashable)
 import Data.Map.Strict (Map)
 import Data.Maybe (fromMaybe)
 import Data.Monoid
-import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..),PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace,MaybePatch(Mod), unMod, old, new)
+import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..), PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace, MaybePatch(Mod), unMod, old, new)
 import Data.Set (Set)
 import Data.String (IsString, fromString)
 import Data.Swagger hiding (version, patch)
@@ -32,10 +31,9 @@ import Data.Validity
 import Database.PostgreSQL.Simple.FromField (FromField, fromField, ResultError(ConversionFailed), returnError)
 import GHC.Generics (Generic)
 import Gargantext.Core.Text (size)
-import Gargantext.Core.Types (ListType(..), ListId, NodeId)
-import Gargantext.Core.Types (TODO)
+import Gargantext.Core.Types (ListType(..), ListId, NodeId, TODO)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger, wellNamedSchema)
-import Gargantext.Database.Prelude (fromField', CmdM', HasConnectionPool, HasConfig)
+import Gargantext.Database.Prelude (fromField', HasConnectionPool, HasConfig, CmdM')
 import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Hash (IsHashable(..))
 import Protolude (maybeToEither)
@@ -53,6 +51,7 @@ import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
 
 ------------------------------------------------------------------------
 
+type QueryParamR = QueryParam' '[Required, Strict]
 
 ------------------------------------------------------------------------
 --data FacetFormat = Table | Chart
@@ -251,16 +250,16 @@ toNgramsElement ns = map toNgramsElement' ns
 
 mockTable :: NgramsTable
 mockTable = NgramsTable
-  [ mkNgramsElement "animal"  MapTerm      Nothing       (mSetFromList ["dog", "cat"])
-  , mkNgramsElement "cat"     MapTerm     (rp "animal")  mempty
+  [ mkNgramsElement "animal"  MapTerm        Nothing       (mSetFromList ["dog", "cat"])
+  , mkNgramsElement "cat"     MapTerm       (rp "animal")  mempty
   , mkNgramsElement "cats"    StopTerm       Nothing       mempty
-  , mkNgramsElement "dog"     MapTerm     (rp "animal")  (mSetFromList ["dogs"])
+  , mkNgramsElement "dog"     MapTerm       (rp "animal")  (mSetFromList ["dogs"])
   , mkNgramsElement "dogs"    StopTerm      (rp "dog")     mempty
-  , mkNgramsElement "fox"     MapTerm      Nothing       mempty
+  , mkNgramsElement "fox"     MapTerm        Nothing       mempty
   , mkNgramsElement "object"  CandidateTerm  Nothing       mempty
   , mkNgramsElement "nothing" StopTerm       Nothing       mempty
-  , mkNgramsElement "organic" MapTerm      Nothing       (mSetFromList ["flower"])
-  , mkNgramsElement "flower"  MapTerm     (rp "organic") mempty
+  , mkNgramsElement "organic" MapTerm        Nothing       (mSetFromList ["flower"])
+  , mkNgramsElement "flower"  MapTerm       (rp "organic") mempty
   , mkNgramsElement "moon"    CandidateTerm  Nothing       mempty
   , mkNgramsElement "sky"     StopTerm       Nothing       mempty
   ]
@@ -533,6 +532,7 @@ instance FromField (PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTable
 type instance ConflictResolution NgramsTablePatch =
   NgramsTerm -> ConflictResolutionNgramsPatch
 
+
 type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
   -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
 type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
@@ -577,7 +577,7 @@ ngramsElementFromRepo
                 , _ne_parent      = p
                 , _ne_children    = c
                 , _ne_ngrams      = ngrams
-                , _ne_occurrences = panic $ "API.Ngrams._ne_occurrences"
+                , _ne_occurrences = panic $ "API.Ngrams.Types._ne_occurrences"
                 {-
                 -- Here we could use 0 if we want to avoid any `panic`.
                 -- It will not happen using getTableNgrams if
@@ -666,6 +666,8 @@ instance Arbitrary a => Arbitrary (VersionedWithCount a) where
 toVersionedWithCount :: Count -> Versioned a -> VersionedWithCount a
 toVersionedWithCount count (Versioned version data_) = VersionedWithCount version count data_
 ------------------------------------------------------------------------
+
+-- | TOREMOVE
 data Repo s p = Repo
   { _r_version :: !Version
   , _r_state   :: !s
@@ -674,6 +676,13 @@ data Repo s p = Repo
   }
   deriving (Generic, Show)
 
+-- | TO REMOVE
+type NgramsRepo       = Repo     NgramsState NgramsStatePatch
+type NgramsState      = Map      TableNgrams.NgramsType (Map NodeId NgramsTableMap)
+type NgramsStatePatch = PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch)
+
+----------------------------------------------------------------------
+
 instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
   parseJSON = genericParseJSON $ unPrefix "_r_"
 
@@ -688,10 +697,6 @@ makeLenses ''Repo
 initRepo :: Monoid s => Repo s p
 initRepo = Repo 1 mempty []
 
-type NgramsRepo       = Repo NgramsState NgramsStatePatch
-type NgramsState      = Map      TableNgrams.NgramsType (Map NodeId NgramsTableMap)
-type NgramsStatePatch = PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch)
-
 instance Serialise (PM.PatchMap NodeId NgramsTablePatch)
 instance Serialise NgramsStatePatch
 
@@ -703,6 +708,8 @@ initMockRepo = Repo 1 s []
       $ Map.fromList
       [ (n ^. ne_ngrams, ngramsElementToRepo n) | n <- mockTable ^. _NgramsTable ]
 
+--------------------
+
 data RepoEnv = RepoEnv
   { _renv_var   :: !(MVar NgramsRepo)
   , _renv_saver :: !(IO ())
@@ -712,36 +719,32 @@ data RepoEnv = RepoEnv
 
 makeLenses ''RepoEnv
 
+type RepoCmdM   env err m =
+  ( CmdM'             env err m
+  , HasRepo           env
+  , HasConnectionPool env
+  , HasConfig         env
+  )
+
+class (HasRepoVar env, HasRepoSaver env)
+  => HasRepo env where
+  repoEnv :: Getter env RepoEnv
 class HasRepoVar env where
   repoVar :: Getter env (MVar NgramsRepo)
-
-instance HasRepoVar (MVar NgramsRepo) where
-  repoVar = identity
-
 class HasRepoSaver env where
   repoSaver :: Getter env (IO ())
 
-class (HasRepoVar env, HasRepoSaver env) => HasRepo env where
-  repoEnv :: Getter env RepoEnv
 
 instance HasRepo RepoEnv where
   repoEnv = identity
-
+instance HasRepoVar (MVar NgramsRepo) where
+  repoVar = identity
 instance HasRepoVar RepoEnv where
   repoVar = renv_var
-
 instance HasRepoSaver RepoEnv where
   repoSaver = renv_saver
 
-type RepoCmdM   env err m =
-  ( CmdM'             env err m
-  , HasRepo           env
-  , HasConnectionPool env
-  , HasConfig         env
-  )
-
-
-type QueryParamR = QueryParam' '[Required, Strict]
+------------------------------------------------------------------------
 
 
 -- Instances
@@ -756,13 +759,13 @@ instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
 
 ngramsTypeFromTabType :: TabType -> TableNgrams.NgramsType
 ngramsTypeFromTabType tabType =
-  let lieu = "Garg.API.Ngrams: " :: Text in
+  let here = "Garg.API.Ngrams: " :: Text in
     case tabType of
       Sources    -> TableNgrams.Sources
       Authors    -> TableNgrams.Authors
       Institutes -> TableNgrams.Institutes
       Terms      -> TableNgrams.NgramsTerms
-      _          -> panic $ lieu <> "No Ngrams for this tab"
+      _          -> panic $ here <> "No Ngrams for this tab"
       -- TODO: This `panic` would disapear with custom NgramsType.
 
 ----

src/Gargantext/API/Node/Contact.hs

@@ -92,7 +92,7 @@ addContact u nId (AddContactParams fn ln) logStatus = do
                    , _scst_remaining = Just 1
                    , _scst_events    = Just []
                    }
-  _ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) [[hyperdataContact fn ln]]
+  _ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) Nothing [[hyperdataContact fn ln]]
 
   pure  JobLog { _scst_succeeded = Just 2
                , _scst_failed    = Just 0

src/Gargantext/API/Node/Corpus/Export.hs

@@ -26,10 +26,11 @@ import qualified Data.HashMap.Strict as HashMap
 
 import Gargantext.API.Node.Corpus.Export.Types
 import Gargantext.API.Ngrams.Types
-import Gargantext.API.Ngrams.Tools (filterListWithRoot, mapTermListRoot, getRepo)
+import Gargantext.API.Ngrams.Tools (filterListWithRoot, mapTermListRoot, getRepo')
 import Gargantext.API.Prelude (GargNoServer)
 import Gargantext.Prelude.Crypto.Hash (hash)
 import Gargantext.Core.Types
+import Gargantext.Core.NodeStory
 import Gargantext.Database.Action.Metrics.NgramsByNode (getNgramsByNodeOnlyUser)
 import Gargantext.Database.Admin.Config (userMaster)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
@@ -58,7 +59,8 @@ getCorpus cId lId nt' = do
   ns   <- Map.fromList
        <$> map (\n -> (_node_id n, n))
        <$> selectDocNodes cId
-  repo <- getRepo
+
+  repo <- getRepo' [fromMaybe (panic "[Gargantext.API.Node.Corpus.Export]") lId]
   ngs  <- getNodeNgrams cId lId nt repo
   let  -- uniqId is hash computed already for each document imported in database
     r = Map.intersectionWith (\a b -> Document a (Ngrams (Set.toList b) (hash b)) (d_hash a b)
@@ -75,7 +77,7 @@ getNodeNgrams :: HasNodeError err
         => CorpusId
         -> Maybe ListId
         -> NgramsType
-        -> NgramsRepo
+        -> NodeListStory
         -> Cmd err (Map NodeId (Set NgramsTerm))
 getNodeNgrams cId lId' nt repo = do
   lId <- case lId' of

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

@@ -49,7 +49,8 @@ import qualified Gargantext.Core.Text.Corpus.API as API
 import qualified Gargantext.Core.Text.Corpus.Parsers as Parser (FileFormat(..), parseFormat)
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
-import Gargantext.Database.Action.Flow (FlowCmdM, flowCorpus, getDataText, flowDataText, TermType(..){-, allDataOrigins-})
+import Gargantext.Database.Action.Flow (flowCorpus, getDataText, flowDataText, TermType(..){-, allDataOrigins-})
+import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Action.Mail (sendMail)
 import Gargantext.Database.Action.Node (mkNodeWithParent)
 import Gargantext.Database.Action.User (getUserId)
@@ -136,6 +137,7 @@ data WithQuery = WithQuery
   , _wq_datafield :: !Datafield
   , _wq_lang      :: !Lang
   , _wq_node_id   :: !Int
+  -- , _wq_flowListWith :: !FlowSocialListWith
   }
   deriving Generic
 
@@ -212,7 +214,7 @@ addToCorpusWithQuery user cid (WithQuery q dbs datafield l _nid) maybeLimit logS
                        , _scst_events    = Just []
                        }
 
-      cids <- mapM (\txt -> flowDataText user txt (Multi l) cid) txts
+      cids <- mapM (\txt -> flowDataText user txt (Multi l) cid Nothing) txts
       printDebug "corpus id" cids
       printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
       sendMail user
@@ -264,6 +266,7 @@ addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus jobLog = do
       _cid' <- flowCorpus user
                           (Right [cid])
                           (Multi $ fromMaybe EN l)
+                          Nothing
                           (map (map toHyperdataDocument) docs)
 
       printDebug "Extraction finished   : " cid

src/Gargantext/API/Node/Corpus/Searx.hs

@@ -3,6 +3,8 @@
 
 module Gargantext.API.Node.Corpus.Searx where
 
+
+
 import Control.Lens (view)
 import qualified Data.Aeson as Aeson
 import Data.Aeson.TH (deriveJSON)
@@ -19,7 +21,7 @@ import Gargantext.Prelude.Config
 import Gargantext.Core (Lang(..))
 import qualified Gargantext.Core.Text.Corpus.API as API
 import Gargantext.Core.Utils.Prefix (unPrefix)
-import Gargantext.Database.Action.Flow (FlowCmdM)
+import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Admin.Types.Node (CorpusId)
 import Gargantext.Database.Prelude (hasConfig)
 

src/Gargantext/API/Prelude.hs

@@ -33,7 +33,7 @@ import Data.Typeable
 import Data.Validity
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Admin.Types
-import Gargantext.API.Ngrams.Types
+import Gargantext.Core.NodeStory
 import Gargantext.Core.Types
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
@@ -51,10 +51,10 @@ joseError = throwError . (_JoseError #)
 
 type EnvC env =
   ( HasConnectionPool env
-  , HasRepo           env  -- TODO rename HasNgramsRepo
   , HasSettings       env  -- TODO rename HasDbSettings
   , HasJobEnv         env JobLog JobLog
   , HasConfig         env
+  , HasNodeStoryEnv    env
   )
 
 type ErrC err =
@@ -69,6 +69,7 @@ type ErrC err =
 
 type GargServerC env err m =
   ( CmdRandom env err m
+  , HasNodeStory env err m
   , EnvC  env
   , ErrC      err
   , MimeRender JSON err
@@ -91,7 +92,7 @@ type GargNoServer t =
 
 type GargNoServer' env err m =
   ( CmdM           env err m
-  , HasRepo        env
+  , HasNodeStory   env err m
   , HasSettings    env
   , HasNodeError       err
   )

src/Gargantext/API/Search.hs

@@ -66,7 +66,7 @@ api nId (SearchQuery q SearchContact) o l order = do
             <$> SearchResultContact
             <$> map (toRow aId)
             <$> searchInCorpusWithContacts nId aId q o l order
-api _ _ _ _ _ = undefined
+api _ _ _ _ _ = panic "[G.A.Search.api] undefined"
 
 -----------------------------------------------------------------------
 -----------------------------------------------------------------------

src/Gargantext/API/Swagger.hs

@@ -25,7 +25,7 @@ import Gargantext.Prelude
 -- | Swagger Specifications
 swaggerDoc :: Swagger
 swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
-  & info.title       .~ "Gargantext"
+  & info.title       .~ "GarganText"
   & info.version     .~ (cs $ showVersion PG.version)
   -- & info.base_url     ?~ (URL "http://gargantext.org/")
   & info.description ?~ "REST API specifications"
@@ -34,4 +34,4 @@ swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
                  ["Gargantext" & description ?~ "Main operations"]
   & info.license     ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence )
     where
-        urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
\ No newline at end of file
+        urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"

src/Gargantext/Core/Text/List.hs

@@ -23,7 +23,8 @@ import Data.Monoid (mempty)
 import Data.Ord (Down(..))
 import Data.Set (Set)
 import Data.Tuple.Extra (both)
-import Gargantext.API.Ngrams.Types (NgramsElement, RepoCmdM, NgramsTerm(..))
+import Gargantext.API.Ngrams.Types (NgramsElement, NgramsTerm(..))
+import Gargantext.Core.NodeStory
 import Gargantext.Core.Text (size)
 import Gargantext.Core.Text.List.Group
 import Gargantext.Core.Text.List.Group.Prelude
@@ -34,22 +35,22 @@ import Gargantext.Core.Text.Metrics (scored', Scored(..), scored_speExc, scored_
 import Gargantext.Core.Types (ListType(..), MasterCorpusId, UserCorpusId)
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsUser, getNodesByNgramsOnlyUser)
-import Gargantext.Database.Action.Metrics.TFICF (getTficf)
+import Gargantext.Database.Action.Metrics.TFICF (getTficf_withSample)
 import Gargantext.Database.Admin.Types.Node (NodeId)
 import Gargantext.Database.Prelude (CmdM)
 import Gargantext.Database.Query.Table.Ngrams (text2ngrams)
-import Gargantext.Database.Query.Table.Node (defaultList)
 import Gargantext.Database.Query.Table.NgramsPostag (selectLems)
+import Gargantext.Database.Query.Table.Node (defaultList)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
 import Gargantext.Database.Query.Tree.Error (HasTreeError)
 import Gargantext.Database.Schema.Ngrams (NgramsType(..), Ngrams(..))
 import Gargantext.Prelude
 import qualified Data.HashMap.Strict as HashMap
+import qualified Data.HashSet as HashSet
 import qualified Data.List    as List
 import qualified Data.Map     as Map
 import qualified Data.Set     as Set
 import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
-import qualified Data.HashSet as HashSet
 
 {-
 -- TODO maybe useful for later
@@ -61,19 +62,20 @@ isStopTerm (StopSize n) x = Text.length x < n || any isStopChar (Text.unpack x)
 
 
 -- | TODO improve grouping functions of Authors, Sources, Institutes..
-buildNgramsLists :: ( RepoCmdM env err m
+buildNgramsLists :: ( HasNodeStory env err m
                     , CmdM     env err m
                     , HasTreeError err
                     , HasNodeError err
                     )
-                 => GroupParams
-                 -> User
+                 => User
                  -> UserCorpusId
                  -> MasterCorpusId
+                 -> Maybe FlowSocialListWith
+                 -> GroupParams
                  -> m (Map NgramsType [NgramsElement])
-buildNgramsLists gp user uCid mCid = do
-  ngTerms     <- buildNgramsTermsList user uCid mCid gp (NgramsTerms, MapListSize 350)
-  othersTerms <- mapM (buildNgramsOthersList user uCid GroupIdentity)
+buildNgramsLists user uCid mCid mfslw gp = do
+  ngTerms     <- buildNgramsTermsList user uCid mCid mfslw gp (NgramsTerms, MapListSize 350)
+  othersTerms <- mapM (buildNgramsOthersList user uCid mfslw GroupIdentity)
                       [ (Authors   , MapListSize 9)
                       , (Sources   , MapListSize 9)
                       , (Institutes, MapListSize 9)
@@ -86,20 +88,21 @@ data MapListSize = MapListSize { unMapListSize :: !Int }
 
 buildNgramsOthersList ::( HasNodeError err
                         , CmdM     env err m
-                        , RepoCmdM env err m
+                        , HasNodeStory env err m
                         , HasTreeError err
                         )
                         => User
                         -> UserCorpusId
+                        -> Maybe FlowSocialListWith
                         -> GroupParams
                         -> (NgramsType, MapListSize)
                         -> m (Map NgramsType [NgramsElement])
-buildNgramsOthersList user uCid _groupParams (nt, MapListSize mapListSize) = do
+buildNgramsOthersList user uCid mfslw _groupParams (nt, MapListSize mapListSize) = do
   allTerms  :: HashMap NgramsTerm (Set NodeId) <- getNodesByNgramsUser uCid nt
 
   -- PrivateFirst for first developments since Public NodeMode is not implemented yet
   socialLists :: FlowCont NgramsTerm FlowListScores
-    <- flowSocialList MySelfFirst user nt ( FlowCont HashMap.empty
+    <- flowSocialList mfslw user nt ( FlowCont HashMap.empty
                                                       $ HashMap.fromList
                                                       $ List.zip (HashMap.keys allTerms)
                                                                  (List.cycle [mempty])
@@ -128,7 +131,7 @@ buildNgramsOthersList user uCid _groupParams (nt, MapListSize mapListSize) = do
 
 getGroupParams :: ( HasNodeError err
                   , CmdM     env err m
-                  , RepoCmdM env err m
+                  , HasNodeStory env err m
                   , HasTreeError err
                   )
                => GroupParams -> HashSet Ngrams -> m GroupParams
@@ -142,28 +145,34 @@ getGroupParams gp _ = pure gp
 -- TODO use ListIds
 buildNgramsTermsList :: ( HasNodeError err
                         , CmdM     env err m
-                        , RepoCmdM env err m
+                        , HasNodeStory env err m
                         , HasTreeError err
                         )
                         => User
                         -> UserCorpusId
                         -> MasterCorpusId
+                        -> Maybe FlowSocialListWith
                         -> GroupParams
                         -> (NgramsType, MapListSize)
                         -> m (Map NgramsType [NgramsElement])
-buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
+buildNgramsTermsList user uCid mCid mfslw groupParams (nt, _mapListSize)= do
 
 -- Filter 0 With Double
 -- Computing global speGen score
-  allTerms :: HashMap NgramsTerm Double <- getTficf uCid mCid nt
+  printDebug "[buldNgramsTermsList: Sample List] / start" nt
+  allTerms :: HashMap NgramsTerm Double <- getTficf_withSample uCid mCid nt
+  printDebug "[buldNgramsTermsList: Sample List / end]" nt
 
+  printDebug "[buldNgramsTermsList: Flow Social List / start]" nt
   -- PrivateFirst for first developments since Public NodeMode is not implemented yet
   socialLists :: FlowCont NgramsTerm FlowListScores
-    <- flowSocialList MySelfFirst user nt ( FlowCont HashMap.empty
+    <- flowSocialList mfslw user nt ( FlowCont HashMap.empty
                                                       $ HashMap.fromList
                                                       $ List.zip (HashMap.keys   allTerms)
                                                                  (List.cycle     [mempty])
                                            )
+  printDebug "[buldNgramsTermsList: Flow Social List / end]" nt
+
   let ngramsKeys = HashMap.keysSet allTerms
 
   groupParams' <- getGroupParams groupParams (HashSet.map (text2ngrams . unNgramsTerm) ngramsKeys)
@@ -214,7 +223,7 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
                                 $ setScoresWithMap mapTextDocIds (groupedMonoHead <> groupedMultHead)
 
 
-  printDebug "groupedTreeScores_SetNodeId" groupedTreeScores_SetNodeId
+  --printDebug "groupedTreeScores_SetNodeId" groupedTreeScores_SetNodeId
 
   -- Coocurrences computation
   --, t1 >= t2 -- permute byAxis diag  -- since matrix symmetric

src/Gargantext/Core/Text/List/Social.hs

@@ -16,6 +16,7 @@ import Data.Map (Map)
 import Data.Monoid (mconcat)
 import Gargantext.API.Ngrams.Tools
 import Gargantext.API.Ngrams.Types
+import Gargantext.Core.NodeStory
 import Gargantext.Core.Text.List.Social.Find
 import Gargantext.Core.Text.List.Social.History
 import Gargantext.Core.Text.List.Social.Patch
@@ -35,8 +36,12 @@ import Gargantext.Prelude
 -- | FlowSocialListPriority
 -- Sociological assumption: either private or others (public) first
 -- This parameter depends on the user choice
-data FlowSocialListPriority = MySelfFirst | OthersFirst
 
+data FlowSocialListWith = FlowSocialListWithPriority { fslw_priority :: FlowSocialListPriority }
+                        | FlowSocialListWithLists    { fslw_lists :: [ListId] }
+
+
+data FlowSocialListPriority = MySelfFirst | OthersFirst
 flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
 flowSocialListPriority MySelfFirst = [Private{-, Shared, Public -}]
 flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
@@ -49,7 +54,21 @@ keepAllParents _           = KeepAllParents True
 -}
 
 ------------------------------------------------------------------------
-flowSocialList :: ( RepoCmdM env err m
+flowSocialList :: ( HasNodeStory env err m
+                   , CmdM     env err m
+                   , HasNodeError err
+                   , HasTreeError err
+                   )
+                  => Maybe FlowSocialListWith
+                  -> User
+                  -> NgramsType
+                  -> FlowCont NgramsTerm FlowListScores
+                  -> m (FlowCont NgramsTerm FlowListScores)
+flowSocialList Nothing u = flowSocialList' MySelfFirst u
+flowSocialList (Just (FlowSocialListWithPriority p)) u = flowSocialList' p u
+flowSocialList (Just (FlowSocialListWithLists    ls)) _ = getHistoryScores ls History_User
+
+flowSocialList' :: ( HasNodeStory env err m
                    , CmdM     env err m
                    , HasNodeError err
                    , HasTreeError err
@@ -58,12 +77,12 @@ flowSocialList :: ( RepoCmdM env err m
                   -> User -> NgramsType
                   -> FlowCont NgramsTerm FlowListScores
                   -> m (FlowCont NgramsTerm FlowListScores)
-flowSocialList flowPriority user nt flc =
+flowSocialList' flowPriority user nt flc =
   mconcat <$> mapM (flowSocialListByMode'   user nt flc)
                    (flowSocialListPriority flowPriority)
     where
 
-      flowSocialListByMode' :: ( RepoCmdM env err m
+      flowSocialListByMode' :: ( HasNodeStory env err m
                                , CmdM     env err m
                                , HasNodeError err
                                , HasTreeError err
@@ -77,7 +96,7 @@ flowSocialList flowPriority user nt flc =
         >>= flowSocialListByModeWith nt' flc'
 
 
-      flowSocialListByModeWith :: ( RepoCmdM env err m
+      flowSocialListByModeWith :: ( HasNodeStory env err m
                                   , CmdM     env err m
                                   , HasNodeError err
                                   , HasTreeError err
@@ -87,27 +106,24 @@ flowSocialList flowPriority user nt flc =
                                -> [ListId]
                                -> m (FlowCont NgramsTerm FlowListScores)
       flowSocialListByModeWith nt'' flc'' listes =
-        getHistoryScores History_User nt'' flc'' listes
-        {-
-            mapM (\l -> getListNgrams [l] nt'') listes
-        >>= pure
-          . toFlowListScores (keepAllParents nt'') flc''
-        -}
+        getHistoryScores listes History_User nt'' flc''
+
+
 -----------------------------------------------------------------
-getHistoryScores :: ( RepoCmdM env err m
-                    , CmdM     env err m
-                    , HasNodeError err
-                    , HasTreeError err
+getHistoryScores :: ( HasNodeStory env err m
+                    , CmdM         env err m
+                    , HasNodeError     err
+                    , HasTreeError     err
                     )
-                 => History
+                 => [ListId]
+                 -> History
                  -> NgramsType
                  -> FlowCont NgramsTerm FlowListScores
-                 -> [ListId]
                  -> m (FlowCont NgramsTerm FlowListScores)
-getHistoryScores hist nt fl listes =
-  addScorePatches nt listes fl <$> getHistory hist nt listes
+getHistoryScores lists hist nt fl =
+  addScorePatches nt lists fl <$> getHistory hist nt lists
 
-getHistory :: ( RepoCmdM env err m
+getHistory :: ( HasNodeStory env err m
               , CmdM     env err m
               , HasNodeError err
               , HasTreeError err
@@ -115,7 +131,7 @@ getHistory :: ( RepoCmdM env err m
            => History
            -> NgramsType
            -> [ListId]
-           -> m (Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch]))
+           -> m (Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch]))
 getHistory hist nt listes =
-  history hist [nt] listes  <$> getRepo
+  history hist [nt] listes  <$> getRepo' listes
 

src/Gargantext/Core/Text/List/Social/History.hs

@@ -15,6 +15,7 @@ import Control.Lens hiding (cons)
 import Data.HashMap.Strict (HashMap)
 import Data.Map (Map)
 import Gargantext.API.Ngrams.Types
+import Gargantext.Core.NodeStory
 import Gargantext.Core.Text.List.Social.Prelude
 import Gargantext.Core.Types (ListId)
 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
@@ -37,8 +38,8 @@ data History = History_User
 history :: History
         -> [NgramsType]
         -> [ListId]
-        -> Repo s NgramsStatePatch
-        -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
+        -> NodeStory s NgramsStatePatch'
+        -> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
 history History_User t l = clean . (history' t l)
   where
     clean = Map.map (Map.map List.init)
@@ -53,35 +54,19 @@ history _ t l = history' t l
 ------------------------------------------------------------------------
 history' :: [NgramsType]
         -> [ListId]
-        -> Repo s NgramsStatePatch
-        -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-history' types lists = merge
-                    . map (Map.map ( Map.map cons))
-                    . map (Map.map ((Map.filterWithKey (\k _ -> List.elem k lists))))
-                    . map           (Map.filterWithKey (\k _ -> List.elem k types))
-                    . map toMap
-                    . view r_history
-
-
-merge :: [Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])]
-      ->  Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-merge = Map.unionsWith merge'
+        -> NodeStory s NgramsStatePatch'
+        -> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
+history' types lists = (Map.map (Map.unionsWith (<>)))
+                    . (Map.map (map (Map.filterWithKey (\k _ -> List.elem k types))))
+                    . (Map.map (map toMap))
+                    . (Map.map (view a_history))
+                    . (Map.filterWithKey (\k _ -> List.elem k lists))
+                    . (view unNodeStory)
   where
-    merge' :: Map ListId [HashMap NgramsTerm NgramsPatch]
-           -> Map ListId [HashMap NgramsTerm NgramsPatch]
-           -> Map ListId [HashMap NgramsTerm NgramsPatch]
-    merge' = Map.unionWith (<>)
 
+    toMap :: PatchMap NgramsType NgramsTablePatch
+          -> Map NgramsType [HashMap NgramsTerm NgramsPatch]
+    toMap m = Map.map (cons . unNgramsTablePatch)
+            $ unPatchMapToMap m
 
-toMap :: PatchMap NgramsType
-           (PatchMap ListId
-            (NgramsTablePatch
-            )
-          )
-        -> Map NgramsType
-           (Map ListId
-            (HashMap NgramsTerm NgramsPatch
-            )
-           )
-toMap = Map.map (Map.map unNgramsTablePatch) . (Map.map unPatchMapToMap) . unPatchMapToMap
 

src/Gargantext/Core/Text/List/Social/Patch.hs

@@ -30,27 +30,29 @@ import qualified Data.Patch.Class    as Patch (Replace(..))
 
 addScorePatches :: NgramsType -> [ListId]
                 -> FlowCont NgramsTerm FlowListScores
-                -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
+                -> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
                 -> FlowCont NgramsTerm FlowListScores
-addScorePatches nt listes fl repo = foldl' (addScorePatchesList nt repo) fl listes
+addScorePatches nt listes fl repo =
+  foldl' (addScorePatchesList nt repo) fl listes
 
 
 addScorePatchesList :: NgramsType
-                   -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
+                   -- -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
+                   -> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
                    -> FlowCont NgramsTerm FlowListScores
                    -> ListId
                    -> FlowCont NgramsTerm FlowListScores
-addScorePatchesList nt repo fl lid = foldl' addScorePatch fl patches
+addScorePatchesList nt repo fl lid =
+  foldl' addScorePatch fl patches
   where
     patches = maybe [] (List.concat . (map HashMap.toList)) patches'
 
     patches' = do
-      lists      <- Map.lookup nt repo
-      mapPatches <- Map.lookup lid lists
+      lists      <- Map.lookup lid repo
+      mapPatches <- Map.lookup nt lists
       pure mapPatches
 
 
-
 addScorePatch :: FlowCont NgramsTerm FlowListScores
               -> (NgramsTerm , NgramsPatch)
               -> FlowCont NgramsTerm FlowListScores

src/Gargantext/Core/Viz/Chart.hs

@@ -35,7 +35,7 @@ import Gargantext.API.Ngrams.NgramsTree
 import Gargantext.API.Ngrams.Tools
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types
-import Gargantext.Database.Action.Flow
+import Gargantext.Database.Action.Flow.Types
 import Gargantext.Database.Action.Metrics.NgramsByNode
 import Gargantext.Database.Schema.Ngrams
 import Gargantext.Core.Viz.Types
@@ -59,7 +59,7 @@ chartData :: FlowCmdM env err m
 chartData cId nt lt = do
   ls' <- selectNodesWithUsername NodeList userMaster
   ls <- map (_node_id) <$> getListsWithParentId cId
-  ts <- mapTermListRoot ls nt <$> getRepo
+  ts <- mapTermListRoot ls nt <$> getRepo' ls
   let
     dico = filterListWithRoot lt ts
     terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ HashMap.toList dico
@@ -79,7 +79,7 @@ treeData :: FlowCmdM env err m
 treeData cId nt lt = do
   ls' <- selectNodesWithUsername NodeList userMaster
   ls <- map (_node_id) <$> getListsWithParentId cId
-  ts <- mapTermListRoot ls nt <$> getRepo
+  ts <- mapTermListRoot ls nt <$> getRepo' ls
 
   let
     dico = filterListWithRoot lt ts

src/Gargantext/Core/Viz/Graph/API.hs

@@ -16,18 +16,18 @@ Portability : POSIX
 module Gargantext.Core.Viz.Graph.API
   where
 
-import Control.Lens (set, (^.), _Just, (^?))
+import Control.Lens (set, (^.), _Just, (^?), at)
 import Data.Aeson
 import Data.Maybe (fromMaybe)
 import Data.Swagger
-import Data.Text
+import Data.Text hiding (head)
 import Debug.Trace (trace)
 import GHC.Generics (Generic)
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Ngrams.Tools
-import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
 import Gargantext.API.Prelude
 import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..), withMetric)
+import Gargantext.Core.NodeStory
 import Gargantext.Core.Types.Main
 import Gargantext.Core.Viz.Graph
 import Gargantext.Core.Viz.Graph.GEXF ()
@@ -42,13 +42,14 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Query.Table.Node.Select
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Query.Table.Node.User (getNodeUser)
+import Gargantext.Database.Schema.Node
 import Gargantext.Database.Schema.Ngrams
-import Gargantext.Database.Schema.Node (node_parent_id, node_hyperdata, node_name, node_user_id)
 import Gargantext.Prelude
 import Servant
 import Servant.Job.Async
 import Servant.XML
 import qualified Data.HashMap.Strict as HashMap
+
 ------------------------------------------------------------------------
 -- | There is no Delete specific API for Graph since it can be deleted
 -- as simple Node.
@@ -80,7 +81,6 @@ graphAPI u n = getGraph         u n
 getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
 getGraph _uId nId = do
   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
-  repo <- getRepo
 
   let
     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
@@ -89,6 +89,9 @@ getGraph _uId nId = do
                   identity
                   $ nodeGraph ^. node_parent_id
 
+  listId <- defaultList cId
+  repo <- getRepo' [listId]
+
   -- TODO Distance in Graph params
   case graph of
     Nothing     -> do
@@ -118,9 +121,7 @@ recomputeGraph _uId nId maybeDistance = do
                       Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
                       _       -> maybeDistance
 
-  repo <- getRepo
   let
-    v   = repo ^. r_version
     cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
                   identity
                   $ nodeGraph ^. node_parent_id
@@ -128,6 +129,10 @@ recomputeGraph _uId nId maybeDistance = do
                    Nothing -> withMetric Order1
                    Just m  -> withMetric m
 
+  listId  <- defaultList cId
+  repo <- getRepo' [listId]
+  let v   = repo ^. unNodeStory . at listId . _Just . a_version
+
   case graph of
     Nothing     -> do
       graph' <- computeGraph cId similarity NgramsTerms repo
@@ -150,7 +155,7 @@ computeGraph :: HasNodeError err
              => CorpusId
              -> Distance
              -> NgramsType
-             -> NgramsRepo
+             -> NodeListStory
              -> Cmd err Graph
 computeGraph cId d nt repo = do
   lId  <- defaultList cId
@@ -175,7 +180,7 @@ computeGraph cId d nt repo = do
 defaultGraphMetadata :: HasNodeError err
                      => CorpusId
                      -> Text
-                     -> NgramsRepo
+                     -> NodeListStory
                      -> GraphMetric
                      -> Cmd err GraphMetadata
 defaultGraphMetadata cId t repo gm = do
@@ -191,7 +196,7 @@ defaultGraphMetadata cId t repo gm = do
         , LegendField 3 "#FFF" "Cluster3"
         , LegendField 4 "#FFF" "Cluster4"
         ]
-      , _gm_list = (ListForGraph lId (repo ^. r_version))
+      , _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
       , _gm_startForceAtlas = True
     }
                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
@@ -252,8 +257,13 @@ graphVersions nId = do
                 . gm_list
                 . lfg_version
 
-  repo <- getRepo
-  let v = repo ^. r_version
+    cId = maybe (panic "[G.V.G.API] Node has no parent")
+                  identity
+                  $ nodeGraph ^. node_parent_id
+
+  listId <- defaultList cId
+  repo <- getRepo' [listId]
+  let v = repo ^. unNodeStory . at listId . _Just . a_version
 
   pure $ GraphVersions { gv_graph = listVersion
                        , gv_repo = v }

src/Gargantext/Core/Viz/Phylo/Legacy/LegacyMain.hs

@@ -28,13 +28,13 @@ import Gargantext.Core.Text.Context (TermList)
 import Gargantext.Core.Text.Terms.WithList
 import Gargantext.Database.Query.Table.Node(defaultList)
 import Gargantext.Prelude
-import Gargantext.Database.Action.Flow
+import Gargantext.Database.Action.Flow.Types
 import Gargantext.Core.Viz.LegacyPhylo hiding (Svg, Dot)
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
 import Gargantext.Database.Query.Table.NodeNode (selectDocs)
 import Gargantext.Core.Types
-
+import Gargantext.Core (HasDBid)
 
 -- import Gargantext.Core.Viz.Phylo.LevelMaker (toPhylo)
 -- import Gargantext.Core.Viz.Phylo.Tools
@@ -46,7 +46,7 @@ import qualified Data.Text           as Text
 
 type MinSizeBranch = Int
 
-flowPhylo :: FlowCmdM env err m
+flowPhylo :: (FlowCmdM env err m, HasDBid NodeType)
           => CorpusId
           -> m Phylo
 flowPhylo cId = do

src/Gargantext/Database/Action/Delete.hs

@@ -36,7 +36,9 @@ import Gargantext.Prelude
 import qualified Gargantext.Database.GargDB as GargDB
 
 ------------------------------------------------------------------------
-
+-- TODO
+-- Delete Corpus children accoring its types
+-- Delete NodeList (NodeStory + cbor file)
 deleteNode :: (HasConfig env, HasConnectionPool env, HasNodeError err)
            => User
            -> NodeId
@@ -44,7 +46,7 @@ deleteNode :: (HasConfig env, HasConnectionPool env, HasNodeError err)
 deleteNode u nodeId = do
   node' <- N.getNode nodeId
   case (view node_typename node') of
-    nt | nt == toDBid NodeUser -> panic "Not allowed to delete NodeUser (yet)"
+    nt | nt == toDBid NodeUser -> panic "[G.D.A.D.deleteNode] Not allowed to delete NodeUser (yet)"
     nt | nt == toDBid NodeTeam -> do
       uId   <- getUserId u
       if _node_user_id node' == uId

src/Gargantext/Database/Action/Flow.hs

@@ -24,8 +24,7 @@ Portability : POSIX
 {-# LANGUAGE TemplateHaskell         #-}
 
 module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
-  ( FlowCmdM
-  , getDataText
+  ( getDataText
   , flowDataText
   , flow
 
@@ -73,6 +72,7 @@ import Gargantext.Core.Text
 import Gargantext.Core.Text.List.Group.WithStem ({-StopSize(..),-} GroupParams(..))
 import Gargantext.Core.Text.Corpus.Parsers (parseFile, FileFormat)
 import Gargantext.Core.Text.List (buildNgramsLists)
+import Gargantext.Core.Text.List.Social (FlowSocialListWith)
 import Gargantext.Core.Text.Terms
 import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
 import Gargantext.Core.Types (POS(NP))
@@ -152,11 +152,12 @@ flowDataText :: ( FlowCmdM env err m
                 -> DataText
                 -> TermType Lang
                 -> CorpusId
+                -> Maybe FlowSocialListWith
                 -> m CorpusId
-flowDataText u (DataOld ids) tt cid = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids
+flowDataText u (DataOld ids) tt cid mfslw = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids mfslw
   where
     corpusType = (Nothing :: Maybe HyperdataCorpus)
-flowDataText u (DataNew txt) tt cid = flowCorpus u (Right [cid]) tt txt
+flowDataText u (DataNew txt) tt cid mfslw = flowCorpus u (Right [cid]) tt mfslw txt
 
 ------------------------------------------------------------------------
 -- TODO use proxy
@@ -168,7 +169,7 @@ flowAnnuaire :: (FlowCmdM env err m)
              -> m AnnuaireId
 flowAnnuaire u n l filePath = do
   docs <- liftBase $ (( splitEvery 500 <$> readFile_Annuaire filePath) :: IO [[HyperdataContact]])
-  flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
+  flow (Nothing :: Maybe HyperdataAnnuaire) u n l Nothing docs
 
 ------------------------------------------------------------------------
 flowCorpusFile :: (FlowCmdM env err m)
@@ -176,13 +177,14 @@ flowCorpusFile :: (FlowCmdM env err m)
            -> Either CorpusName [CorpusId]
            -> Limit -- Limit the number of docs (for dev purpose)
            -> TermType Lang -> FileFormat -> FilePath
+           -> Maybe FlowSocialListWith
            -> m CorpusId
-flowCorpusFile u n l la ff fp = do
+flowCorpusFile u n l la ff fp mfslw = do
   eParsed <- liftBase $ parseFile ff fp
   case eParsed of
     Right parsed -> do
       let docs = splitEvery 500 $ take l parsed
-      flowCorpus u n la (map (map toHyperdataDocument) docs)
+      flowCorpus u n la mfslw (map (map toHyperdataDocument) docs)
     Left e       -> panic $ "Error: " <> (T.pack e)
 
 ------------------------------------------------------------------------
@@ -192,6 +194,7 @@ flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
            => User
            -> Either CorpusName [CorpusId]
            -> TermType Lang
+           -> Maybe FlowSocialListWith
            -> [[a]]
            -> m CorpusId
 flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
@@ -205,12 +208,13 @@ flow :: ( FlowCmdM env err m
         -> User
         -> Either CorpusName [CorpusId]
         -> TermType Lang
+        -> Maybe FlowSocialListWith
         -> [[a]]
         -> m CorpusId
-flow c u cn la docs = do
+flow c u cn la mfslw docs = do
   -- TODO if public insertMasterDocs else insertUserDocs
   ids <- traverse (insertMasterDocs c la) docs
-  flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
+  flowCorpusUser (la ^. tt_lang) u cn c (concat ids) mfslw
 
 ------------------------------------------------------------------------
 flowCorpusUser :: ( FlowCmdM env err m
@@ -221,8 +225,9 @@ flowCorpusUser :: ( FlowCmdM env err m
                -> Either CorpusName [CorpusId]
                -> Maybe c
                -> [NodeId]
+               -> Maybe FlowSocialListWith
                -> m CorpusId
-flowCorpusUser l user corpusName ctype ids = do
+flowCorpusUser l user corpusName ctype ids mfslw = do
   -- User Flow
   (userId, _rootId, userCorpusId) <- getOrMk_RootWithCorpus user corpusName ctype
   -- NodeTexts is first
@@ -243,7 +248,7 @@ flowCorpusUser l user corpusName ctype ids = do
 
   --let gp = (GroupParams l 2 3 (StopSize 3)) 
   let gp = GroupWithPosTag l CoreNLP HashMap.empty 
-  ngs         <- buildNgramsLists gp user userCorpusId masterCorpusId
+  ngs         <- buildNgramsLists user userCorpusId masterCorpusId mfslw gp
 
   _userListId <- flowList_DbRepo listId ngs
   _mastListId <- getOrMkList masterCorpusId masterUserId

src/Gargantext/Database/Action/Flow/List.hs

@@ -18,15 +18,17 @@ module Gargantext.Database.Action.Flow.List
     where
 
 import Control.Concurrent
-import Control.Lens (view, (^.), (+~), (%~), at)
+import Control.Lens ((^.), (+~), (%~), at, (.~), _Just)
 import Control.Monad.Reader
 import Data.Map (Map, toList)
 import Data.Maybe (catMaybes)
 import Data.Text (Text)
-import Gargantext.API.Ngrams.Types (HasRepoSaver(..), NgramsElement(..), NgramsPatch(..), NgramsRepoElement(..), NgramsTablePatch(..), NgramsTerm(..), RepoCmdM, ne_ngrams, ngramsElementToRepo, r_history, r_state, r_version, repoVar)
+import Gargantext.API.Ngrams (saveNodeStory)
+import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
+import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types (HasInvalidError(..), assertValid)
 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
-import Gargantext.Core.Utils (something)
+import Gargantext.Core.NodeStory
 import Gargantext.Database.Action.Flow.Types
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
@@ -136,14 +138,12 @@ listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
-
-
 -- NOTE
 -- This is no longer part of the API.
 -- This function is maintained for its usage in Database.Action.Flow.List.
 -- If the given list of ngrams elements contains ngrams already in
 -- the repo, they will be ignored.
-putListNgrams :: (HasInvalidError err, RepoCmdM env err m)
+putListNgrams :: (HasInvalidError err, HasNodeStory env err m)
               => NodeId
               -> TableNgrams.NgramsType
               -> [NgramsElement]
@@ -153,48 +153,33 @@ putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
   where
     m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
 
-putListNgrams' :: (HasInvalidError err, RepoCmdM env err m)
-               => NodeId
-               -> TableNgrams.NgramsType
-               -> Map NgramsTerm NgramsRepoElement
-               -> m ()
-putListNgrams' nodeId ngramsType ns = do
-  -- printDebug "[putListNgrams'] nodeId" nodeId
-  -- printDebug "[putListNgrams'] ngramsType" ngramsType
-  -- printDebug "[putListNgrams'] ns" ns
-
-  let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
-      (p0, p0_validity) = PM.singleton nodeId p1
-      (p, p_validity) = PM.singleton ngramsType p0
-  assertValid p0_validity
-  assertValid p_validity
-  {-
-  -- TODO
-  v <- currentVersion
-  q <- commitStatePatch (Versioned v p)
-  assert empty q
-  -- What if another commit comes in between?
-  -- Shall we have a blindCommitStatePatch? It would not ask for a version but just a patch.
-  -- The modifyMVar_ would test the patch with applicable first.
-  -- If valid the rest would be atomic and no merge is required.
-  -}
-  var <- view repoVar
-  liftBase $ modifyMVar_ var $ \r -> do
-    pure $ r & r_version +~ 1
-             & r_history %~ (p :)
-             & r_state . at ngramsType %~
-               (Just .
-                 (at nodeId %~
-                   ( Just
-                   . (<> ns)
-                   . something
-                   )
-                 )
-                 . something
-               )
-  saveRepo
-
-
-saveRepo :: ( MonadReader env m, MonadBase IO m, HasRepoSaver env )
-         => m ()
-saveRepo = liftBase =<< view repoSaver
+    putListNgrams' :: (HasInvalidError err, HasNodeStory env err m)
+                   => NodeId
+                   -> TableNgrams.NgramsType
+                   -> Map NgramsTerm NgramsRepoElement
+                   -> m ()
+    putListNgrams' listId ngramsType' ns = do
+      -- printDebug "[putListNgrams'] nodeId" nodeId
+      -- printDebug "[putListNgrams'] ngramsType" ngramsType
+      -- printDebug "[putListNgrams'] ns" ns
+
+      let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
+          (p, p_validity) = PM.singleton ngramsType' p1
+      assertValid p_validity
+      {-
+      -- TODO
+      v <- currentVersion
+      q <- commitStatePatch (Versioned v p)
+      assert empty q
+      -- What if another commit comes in between?
+      -- Shall we have a blindCommitStatePatch? It would not ask for a version but just a patch.
+      -- The modifyMVar_ would test the patch with applicable first.
+      -- If valid the rest would be atomic and no merge is required.
+      -}
+      var <- getNodeStoryVar [listId]
+      liftBase $ modifyMVar_ var $ \r -> do
+        pure $ r & unNodeStory . at listId . _Just . a_version +~ 1
+                 & unNodeStory . at listId . _Just . a_history %~ (p :)
+                 & unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
+      saveNodeStory
+

src/Gargantext/Database/Action/Flow/Pairing.hs

@@ -179,8 +179,8 @@ getNgramsDocId :: CorpusId
                 -> NgramsType
                 -> GargNoServer (HashMap DocAuthor (Set NodeId))
 getNgramsDocId cId lId nt = do
-  repo <- getRepo
   lIds <- selectNodesWithUsername NodeList userMaster
+  repo <- getRepo' lIds
   let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
 
   groupNodesByNgrams ngs

src/Gargantext/Database/Action/Flow/Types.hs

@@ -21,10 +21,10 @@ module Gargantext.Database.Action.Flow.Types
 
 import Data.Aeson (ToJSON)
 
-import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types (HasInvalidError)
 import Gargantext.Core.Flow.Types
 import Gargantext.Core.Text
+import Gargantext.Core.NodeStory
 import Gargantext.Core.Text.Terms
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Prelude (CmdM)
@@ -33,10 +33,9 @@ import Gargantext.Database.Query.Tree.Error (HasTreeError)
 
 type FlowCmdM env err m =
   ( CmdM     env err m
-  , RepoCmdM env err m
+  , HasNodeStory env err m
   , HasNodeError err
   , HasInvalidError err
-  , HasRepoVar env
   , HasTreeError err
   )
 

src/Gargantext/Database/Action/Metrics.hs

@@ -15,10 +15,11 @@ module Gargantext.Database.Action.Metrics
 
 import Data.HashMap.Strict (HashMap)
 import Data.Vector (Vector)
-import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo)
+import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo')
 import Gargantext.API.Ngrams.Types (TabType(..), ngramsTypeFromTabType, NgramsTerm)
 import Gargantext.Core.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-})
 import Gargantext.Core.Types (ListType(..), Limit, NodeType(..))
+import Gargantext.Core.NodeStory
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser{-, getTficfWith-})
 import Gargantext.Database.Admin.Config (userMaster)
@@ -61,7 +62,7 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do
 
 
 
-getNgrams :: (FlowCmdM env err m)
+getNgrams :: (HasNodeStory env err m)
             => CorpusId -> Maybe ListId -> TabType
             -> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
                  , HashMap NgramsTerm (Maybe RootTerm)
@@ -72,8 +73,11 @@ getNgrams cId maybeListId tabType = do
     Nothing   -> defaultList cId
     Just lId' -> pure lId'
 
-  lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo
+  lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo' [lId]
   let maybeSyn = HM.unions $ map (\t -> filterListWithRoot t lists)
                              [MapTerm, StopTerm, CandidateTerm]
   pure (lists, maybeSyn)
 
+
+
+

src/Gargantext/Database/Action/Metrics/NgramsByNode.hs

@@ -105,6 +105,18 @@ getOccByNgramsOnlyFast cId nt ngs =
   HM.fromListWith (+) <$> selectNgramsOccurrencesOnlyByNodeUser cId nt ngs
 
 
+getOccByNgramsOnlyFast_withSample :: HasDBid NodeType
+                       => CorpusId
+                       -> Int
+                       -> NgramsType
+                       -> [NgramsTerm]
+                       -> Cmd err (HashMap NgramsTerm Int)
+getOccByNgramsOnlyFast_withSample cId int nt ngs =
+  HM.fromListWith (+) <$> selectNgramsOccurrencesOnlyByNodeUser_withSample cId int nt ngs
+
+
+
+
 getOccByNgramsOnlyFast' :: CorpusId
                        -> ListId
                        -> NgramsType
@@ -190,6 +202,8 @@ selectNgramsOccurrencesOnlyByNodeUser cId nt tms =
     where
       fields = [QualifiedIdentifier Nothing "text"]
 
+
+
 -- same as queryNgramsOnlyByNodeUser but using COUNT on the node ids.
 -- Question: with the grouping is the result exactly the same (since Set NodeId for 
 -- equivalent ngrams intersections are not empty)
@@ -208,6 +222,46 @@ queryNgramsOccurrencesOnlyByNodeUser = [sql|
       GROUP BY nng.node2_id, ng.terms
   |]
 
+
+selectNgramsOccurrencesOnlyByNodeUser_withSample :: HasDBid NodeType
+                                      => CorpusId
+                                      -> Int
+                                      -> NgramsType
+                                      -> [NgramsTerm]
+                                      -> Cmd err [(NgramsTerm, Int)]
+selectNgramsOccurrencesOnlyByNodeUser_withSample cId int nt tms =
+  fmap (first NgramsTerm) <$>
+  runPGSQuery queryNgramsOccurrencesOnlyByNodeUser_withSample
+                ( int
+                , toDBid NodeDocument
+                , cId
+                , Values fields ((DPS.Only . unNgramsTerm) <$> tms)
+                , cId
+                , ngramsTypeId nt
+                )
+    where
+      fields = [QualifiedIdentifier Nothing "text"]
+
+queryNgramsOccurrencesOnlyByNodeUser_withSample :: DPS.Query
+queryNgramsOccurrencesOnlyByNodeUser_withSample = [sql|
+  WITH nodes_sample AS (SELECT id FROM nodes n TABLESAMPLE SYSTEM_ROWS (?)
+                          JOIN nodes_nodes nn ON n.id = nn.node2_id
+                            WHERE n.typename  = ?
+                            AND nn.node1_id = ?),
+       input_rows(terms) AS (?)
+  SELECT ng.terms, COUNT(nng.node2_id) FROM node_node_ngrams nng
+    JOIN ngrams ng      ON nng.ngrams_id = ng.id
+    JOIN input_rows  ir ON ir.terms      = ng.terms
+    JOIN nodes_nodes nn ON nn.node2_id   = nng.node2_id
+    JOIN nodes_sample n ON nn.node2_id   = n.id
+    WHERE nn.node1_id     = ? -- CorpusId
+      AND nng.ngrams_type = ? -- NgramsTypeId
+      AND nn.category     > 0
+      GROUP BY nng.node2_id, ng.terms
+  |]
+
+
+
 queryNgramsOccurrencesOnlyByNodeUser' :: DPS.Query
 queryNgramsOccurrencesOnlyByNodeUser' = [sql|
   WITH input_rows(terms) AS (?)

src/Gargantext/Database/Action/Metrics/TFICF.hs

@@ -21,7 +21,7 @@ import qualified Data.HashMap.Strict as HM
 import Data.Maybe (fromMaybe)
 import Gargantext.Core
 import Gargantext.Core.Text.Metrics.TFICF
-import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsUser, getOccByNgramsOnlyFast)
+import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsUser, getOccByNgramsOnlyFast, getOccByNgramsOnlyFast_withSample)
 import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
 import Gargantext.Database.Prelude (Cmd)
 import Gargantext.Database.Query.Table.NodeNode (selectCountDocs)
@@ -52,3 +52,29 @@ getTficf cId mId nt = do
             (TficfSupra (Count $ fromMaybe 0 $ HM.lookup t mapTextDoubleGlobal)
                         (Total $ fromIntegral countGlobal))
     ) mapTextDoubleLocal
+
+
+getTficf_withSample :: HasDBid NodeType 
+         => UserCorpusId
+         -> MasterCorpusId
+         -> NgramsType
+         -> Cmd err (HashMap NgramsTerm Double)
+getTficf_withSample cId mId nt = do
+  mapTextDoubleLocal <- HM.filter (> 1)
+     <$> HM.map (fromIntegral . Set.size)
+     <$> getNodesByNgramsUser cId nt
+
+  countLocal  <- selectCountDocs cId
+  let countGlobal = countLocal * 10
+
+  mapTextDoubleGlobal <- HM.map fromIntegral
+                     <$> getOccByNgramsOnlyFast_withSample mId countGlobal nt
+                            (HM.keys mapTextDoubleLocal)
+
+  pure $ HM.mapWithKey (\t n ->
+      tficf (TficfInfra (Count n                                               )
+                        (Total $ fromIntegral countLocal))
+            (TficfSupra (Count $ fromMaybe 0 $ HM.lookup t mapTextDoubleGlobal)
+                        (Total $ fromIntegral countGlobal))
+    ) mapTextDoubleLocal
+

src/Gargantext/Database/Admin/Types/Node.hs

@@ -131,7 +131,10 @@ pgNodeId = O.pgInt4 . id2int
 
 ------------------------------------------------------------------------
 newtype NodeId = NodeId Int
-  deriving (Show, Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable)
+  deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable)
+
+instance Show NodeId where
+  show (NodeId n) = "nodeId-" <> show n
 
 unNodeId :: NodeId -> Int
 unNodeId (NodeId n) = n