[FIX] Graph concurrency.

bin/gargantext-phylo/Main.hs

@@ -123,7 +123,10 @@ filterTerms patterns (y,d) = (y,termsInText patterns d)
   where
     --------------------------------------
     termsInText :: Patterns -> Text -> [Text]
-    termsInText pats txt = DL.nub $ DL.concat $ map (map unwords) $ extractTermsWithList pats txt
+    termsInText pats txt = DL.nub
+                         $ DL.concat
+                         $ map (map unwords)
+                         $ extractTermsWithList pats txt
     --------------------------------------
 
 

src/Gargantext/API.hs

@@ -47,80 +47,56 @@ Pouillard (who mainly made it).
 module Gargantext.API
       where
 ---------------------------------------------------------------------
-
-import           System.IO (FilePath)
-
-import           GHC.Generics (D1, Meta (..), Rep)
-import           GHC.TypeLits (AppendSymbol, Symbol)
-
-import           Control.Lens
-import           Control.Exception (finally)
-import           Control.Monad.Except (withExceptT, ExceptT)
-import           Control.Monad.IO.Class (liftIO)
-import           Control.Monad.Reader (ReaderT, runReaderT)
-import           Data.Aeson.Encode.Pretty (encodePretty)
-import qualified Data.ByteString.Lazy.Char8 as BL8
-import           Data.Swagger
-import           Data.Text (Text)
-import qualified Data.Text.IO as T
---import qualified Data.Set as Set
-import           Data.Validity
-
-import           Network.Wai
-import           Network.Wai.Handler.Warp hiding (defaultSettings)
-
-import           Servant
-import           Servant.Auth as SA
-import           Servant.Auth.Server (AuthResult(..))
-import           Servant.Auth.Swagger ()
---import           Servant.Mock (mock)
---import           Servant.Job.Server (WithCallbacks)
-import           Servant.Job.Async
-import           Servant.Swagger
-import           Servant.Swagger.UI
--- import Servant.API.Stream
-
---import Gargantext.API.Swagger
-
-import Gargantext.Database.Node.Contact (HyperdataContact)
+import Control.Concurrent (threadDelay)
+import Control.Exception (finally)
+import Control.Lens
+import Control.Monad.Except (withExceptT, ExceptT)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Reader (ReaderT, runReaderT)
+import Data.Aeson.Encode.Pretty (encodePretty)
+import Data.Swagger
+import Data.Text (Text)
+import Data.Validity
+import GHC.Generics (D1, Meta (..), Rep)
+import GHC.TypeLits (AppendSymbol, Symbol)
+import Network.Wai
+import Network.Wai.Handler.Warp hiding (defaultSettings)
+import Servant
+import Servant.Auth as SA
+import Servant.Auth.Server (AuthResult(..))
+import Servant.Auth.Swagger ()
+import Servant.Job.Async
+import Servant.Swagger
+import Servant.Swagger.UI
+import System.IO (FilePath)
+import Data.List (lookup)
+import Data.Text.Encoding (encodeUtf8)
+import GHC.Base (Applicative)
 import Gargantext.API.Auth (AuthRequest, AuthResponse, AuthenticatedUser(..), AuthContext, auth, withAccess, PathId(..))
 import Gargantext.API.Count  ( CountAPI, count, Query)
 import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
 import Gargantext.API.Ngrams (HasRepo(..), HasRepoSaver(..), saveRepo, TableNgramsApi, apiNgramsTableDoc)
 import Gargantext.API.Node
+import Gargantext.API.Orchestrator.Types
 import Gargantext.API.Search (SearchPairsAPI, searchPairs)
+import Gargantext.API.Settings
 import Gargantext.API.Types
-import qualified Gargantext.API.Annuaire as Annuaire
-import qualified Gargantext.API.Export as Export
-import qualified Gargantext.API.Ngrams.List as List
-import qualified Gargantext.API.Corpus.New as New
+import Gargantext.Database.Node.Contact (HyperdataContact)
 import Gargantext.Database.Types.Node
 import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
 import Gargantext.Database.Utils (HasConnection)
 import Gargantext.Prelude
 import Gargantext.Viz.Graph.API
-
---import Gargantext.API.Orchestrator
-import Gargantext.API.Orchestrator.Types
-
----------------------------------------------------------------------
-import GHC.Base (Applicative)
--- import Control.Lens
-
-import Data.List (lookup)
-import Data.Text.Encoding (encodeUtf8)
-
---import Network.Wai (Request, requestHeaders, responseLBS)
+import Network.HTTP.Types hiding (Query)
 import Network.Wai (Request, requestHeaders)
---import qualified Network.Wai.Handler.Warp as Warp
 import Network.Wai.Middleware.Cors
-
 import Network.Wai.Middleware.RequestLogger
--- import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
-
-import Network.HTTP.Types hiding (Query)
-
-import Gargantext.API.Settings
+import qualified Data.ByteString.Lazy.Char8 as BL8
+import qualified Data.Text.IO               as T
+import qualified Gargantext.API.Annuaire    as Annuaire
+import qualified Gargantext.API.Corpus.New  as New
+import qualified Gargantext.API.Export      as Export
+import qualified Gargantext.API.Ngrams.List as List
 
 showAsServantErr :: GargError -> ServerError
 showAsServantErr (GargServerError err) = err
@@ -243,10 +219,14 @@ type GargAdminAPI
 
 ----------------------------------------
 -- For Tests
-type FibAPI = Get '[JSON] Int
-
-fibAPI ::  Int -> GargServer FibAPI
-fibAPI n = pure (fib n)
+type WaitAPI = Get '[JSON] Text
+
+waitAPI ::  Int -> GargServer WaitAPI
+waitAPI n = do
+  let
+    m = (10 :: Int) ^ (6 :: Int)
+  _ <- liftIO $ threadDelay ( m * n)
+  pure $ "Waited: " <> (cs $ show n)
 ----------------------------------------
 
 
@@ -320,9 +300,9 @@ type GargPrivateAPI' =
                        :> Capture "listId" ListId
                        :> List.API
 
-           :<|> "fib" :> Summary "Fib test"
+           :<|> "wait" :> Summary "Wait test"
                       :> Capture "x" Int
-                      :> FibAPI -- Get '[JSON] Int
+                      :> WaitAPI -- Get '[JSON] Int
 
 -- /mv/<id>/<id>
 -- /merge/<id>/<id>
@@ -411,7 +391,7 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
      -- :<|> New.api  uid -- TODO-SECURITY
      -- :<|> New.info uid -- TODO-SECURITY
      :<|> List.api
-     :<|> fibAPI
+     :<|> waitAPI
 
 
 {-

src/Gargantext/API/Ngrams.hs

@@ -789,11 +789,11 @@ instance HasRepoVar RepoEnv where
 instance HasRepoSaver RepoEnv where
   repoSaver = renv_saver
 
-type RepoCmdM env err m =
-  ( MonadReader env m
-  , MonadError err m
-  , MonadIO m
-  , HasRepo env
+type RepoCmdM   env err m =
+  ( MonadReader env     m
+  , MonadError      err m
+  , MonadIO             m
+  , HasRepo     env
   )
 ------------------------------------------------------------------------
 
@@ -1216,12 +1216,9 @@ listNgramsChangedSince listId ngramsType version
   | otherwise   =
       tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
 
-
 -- Instances
 instance Arbitrary NgramsRepoElement where
   arbitrary = elements $ map ngramsElementToRepo ns
     where
       NgramsTable ns = mockTable
 
-
-

src/Gargantext/API/Ngrams/List.hs

@@ -46,6 +46,7 @@ get lId = fromList
        <$> zip ngramsTypes
        <$> mapM (getNgramsTableMap lId) ngramsTypes
 
+-- TODO : purge list
 put :: FlowCmdM env err m
     => ListId
     -> NgramsList
@@ -53,5 +54,7 @@ put :: FlowCmdM env err m
 put l m = do
   -- TODO check with Version for optim
   _ <- mapM (\(nt, Versioned _v ns) -> putListNgrams' l nt ns) $ toList m
+  -- TODO reindex
   pure True
 
+

src/Gargantext/Core/Flow/Types.hs

@@ -10,6 +10,7 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE ConstraintKinds   #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE ConstrainedClassMethods #-}
 
@@ -18,8 +19,10 @@ module Gargantext.Core.Flow.Types where
 import Control.Lens (Lens')
 import Data.Map (Map)
 import Data.Text (Text)
+import Data.Maybe (Maybe)
 import Gargantext.Text.Terms (TermType)
 import Gargantext.Core (Lang)
+import Gargantext.Prelude
 import Gargantext.Database.Schema.Ngrams (Ngrams, NgramsType)
 import Gargantext.Core.Types.Main (HashId)
 import Gargantext.Database.Types.Node -- (HyperdataDocument(..))

src/Gargantext/Text/Terms/WithList.hs

@@ -17,18 +17,15 @@ commentary with @some markup@.
 
 module Gargantext.Text.Terms.WithList where
 
-import qualified Data.Algorithms.KMP as KMP
+import Data.List (null, concatMap)
+import Data.Ord
 import Data.Text (Text, concat)
-import qualified Data.IntMap.Strict as IntMap
-
+import Gargantext.Prelude
 import Gargantext.Text.Context
 import Gargantext.Text.Terms.Mono (monoTextsBySentence)
-
 import Prelude (error)
-import Gargantext.Prelude
-import Data.List (null, concatMap)
-import Data.Ord
-
+import qualified Data.Algorithms.KMP as KMP
+import qualified Data.IntMap.Strict as IntMap
 
 ------------------------------------------------------------------------
 
@@ -40,7 +37,6 @@ data Pattern = Pattern
 type Patterns = [Pattern]
 
 ------------------------------------------------------------------------
-
 replaceTerms :: Patterns -> [Text] -> [[Text]]
 replaceTerms pats terms = go 0
   where
@@ -81,6 +77,25 @@ extractTermsWithList pats = map (replaceTerms pats) . monoTextsBySentence
 -- extractTermsWithList' (buildPatterns termList) "Le chat blanc"["chat blanc"]
 -- ["chat blanc"]
 extractTermsWithList' :: Patterns -> Text -> [Text]
-extractTermsWithList' pats = map (concat . map concat . replaceTerms pats) . monoTextsBySentence
-
+extractTermsWithList' pats = map (concat . map concat . replaceTerms pats)
+                           . monoTextsBySentence
+
+
+filterWith :: TermList
+           -> (a -> Text)
+           -> [a] 
+           -> [(a, [Text])]
+filterWith termList f xs = filterWith' termList f zip xs
+
+
+filterWith' :: TermList
+           -> (a -> Text)
+           -> ([a] -> [[Text]] -> [b])
+           -> [a] 
+           -> [b]
+filterWith' termList f f' xs = f' xs
+                            $ map (extractTermsWithList' pats)
+                            $ map f xs
+    where
+      pats = buildPatterns termList
 

src/Gargantext/Viz/Graph/API.hs

@@ -25,6 +25,7 @@ module Gargantext.Viz.Graph.API
   where
 
 -- import Debug.Trace (trace)
+import Control.Concurrent -- (forkIO)
 import Control.Lens (set, (^.), _Just, (^?))
 import Control.Monad.IO.Class (liftIO)
 import Data.Maybe (Maybe(..))
@@ -61,9 +62,16 @@ graphAPI u n =  getGraph  u n
          :<|> putGraph  n
 
 ------------------------------------------------------------------------
-
 getGraph :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
-getGraph uId nId = do
+getGraph u n = do
+  newGraph  <- liftIO newEmptyMVar
+  g  <- getGraph u n
+  _  <- liftIO $ forkIO $ putMVar newGraph g
+  g' <- liftIO $ takeMVar newGraph
+  pure g'
+
+getGraph' :: UserId -> NodeId -> GargNoServer Graph
+getGraph' uId nId = do
   nodeGraph <- getNodeWith nId HyperdataGraph
   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
   let listVersion = graph ^? _Just