Merge branch 'dev-cache-optimization' of...

Merge branch 'dev-cache-optimization' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell-gargantext into dev-merge

src/Gargantext/API/Ngrams.hs

@@ -108,31 +108,35 @@ import Formatting.Clock (timeSpecs)
 import GHC.Generics (Generic)
 import Servant hiding (Patch)
 import System.Clock (getTime, TimeSpec, Clock(..))
+import Servant.Job.Async (JobFunction(..), serveJobsAPI)
 import System.IO (stderr)
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
 import Prelude (error)
-import Gargantext.Prelude
+import Gargantext.Prelude hiding (log)
 
+import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
 import Gargantext.API.Admin.Types (HasSettings)
 import qualified Gargantext.API.Metrics as Metrics
 import Gargantext.API.Ngrams.Types
-import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, HasInvalidError, TODO, assertValid)
+import Gargantext.API.Prelude
+import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, TODO, assertValid)
 import Gargantext.Core.Utils (something)
 -- import Gargantext.Core.Viz.Graph.API (recomputeGraph)
 -- import Gargantext.Core.Viz.Graph.Distances (Distance(Conditional))
+import Gargantext.Database.Action.Flow.Types
 import Gargantext.Database.Action.Metrics.NgramsByNode (getOccByNgramsOnlyFast')
-import Gargantext.Database.Query.Table.Node.Select
-import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngrams, ngramsType, ngrams_terms)
 import Gargantext.Database.Admin.Config (userMaster)
-import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 import Gargantext.Database.Admin.Types.Node (NodeType(..))
 import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Database.Query.Table.Node.Select
+import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngrams, ngramsType, ngrams_terms)
 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
 import Gargantext.Database.Query.Table.Node (getNode)
-import Gargantext.Database.Query.Tree.Error (HasTreeError)
 import Gargantext.Database.Schema.Node (node_id, node_parentId, node_userId)
+import Gargantext.Prelude.Job
 
 {-
 -- TODO sequences of modifications (Patchs)
@@ -319,13 +323,8 @@ tableNgramsPull listId ngramsType p_version = do
 -- Apply the given patch to the DB and returns the patch to be applied on the
 -- client.
 -- TODO-ACCESS check
-tableNgramsPut :: ( HasNodeError err
-                  , HasTreeError err
-                  , HasInvalidError err
-                  , HasConfig env
-                  , HasConnectionPool env
+tableNgramsPut :: ( FlowCmdM env err m
                   , HasSettings env
-                  , RepoCmdM env err m
                   )
                  => TabType
                  -> ListId
@@ -347,55 +346,87 @@ tableNgramsPut tabType listId (Versioned p_version p_table)
       ret <- commitStatePatch (Versioned p_version p)
         <&> v_data %~ (view (_PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just))
 
+      pure ret
+
+
+tableNgramsPostChartsAsync :: ( FlowCmdM env err m
+                              , HasNodeError err
+                              , HasSettings env
+                              )
+                            => UpdateTableNgramsCharts
+                            -> (JobLog -> m ())
+                            -> m JobLog
+tableNgramsPostChartsAsync utn logStatus = do
+      let tabType = utn ^. utn_tab_type
+      let listId = utn ^. utn_list_id
+
       node <- getNode listId
       let nId = node ^. node_id
           _uId = node ^. node_userId
           mCId = node ^. node_parentId
-      -- printDebug "[tableNgramsPut] updating graph with nId" nId
-      -- printDebug "[tableNgramsPut] updating graph with uId" uId
-      -- _ <- recomputeGraph uId nId Conditional
 
       printDebug "[tableNgramsPut] tabType" tabType
       printDebug "[tableNgramsPut] listId" listId
 
-      _ <- case mCId of
+      case mCId of
         Nothing -> do
           printDebug "[tableNgramsPut] can't update charts, no parent, nId" nId
-          pure ()
+          pure $ jobLogFail $ jobLogInit 1
         Just cId -> do
           case tabType of
             Authors -> do
               -- printDebug "[tableNgramsPut] Authors, updating Pie, cId" cId
+              (logRef, logRefSuccess, getRef) <- runJobLog 1 logStatus
+              logRef
               _ <- Metrics.updatePie cId (Just listId) tabType Nothing
-              pure ()
+              logRefSuccess
+
+              getRef
             Institutes -> do
               -- printDebug "[tableNgramsPut] Institutes, updating Tree, cId" cId
               -- printDebug "[tableNgramsPut] updating tree StopTerm, cId" cId
+              (logRef, logRefSuccess, getRef) <- runJobLog 3 logStatus
+              logRef
               _ <- Metrics.updateTree cId (Just listId) tabType StopTerm
               -- printDebug "[tableNgramsPut] updating tree CandidateTerm, cId" cId
+              logRefSuccess
               _ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
               -- printDebug "[tableNgramsPut] updating tree MapTerm, cId" cId
+              logRefSuccess
               _ <- Metrics.updateTree cId (Just listId) tabType MapTerm
-              pure ()
+              logRefSuccess
+
+              getRef
             Sources -> do
               -- printDebug "[tableNgramsPut] Sources, updating chart, cId" cId
+              (logRef, logRefSuccess, getRef) <- runJobLog 1 logStatus
+              logRef
               _ <- Metrics.updatePie cId (Just listId) tabType Nothing
-              pure ()
+              logRefSuccess
+
+              getRef
             Terms -> do
               -- printDebug "[tableNgramsPut] Terms, updating Metrics (Histo), cId" cId
+              (logRef, logRefSuccess, getRef) <- runJobLog 6 logStatus
+              logRef
               _ <- Metrics.updateChart cId (Just listId) tabType Nothing
+              logRefSuccess
               _ <- Metrics.updatePie cId (Just listId) tabType Nothing
+              logRefSuccess
               _ <- Metrics.updateScatter cId (Just listId) tabType Nothing
+              logRefSuccess
               _ <- Metrics.updateTree cId (Just listId) tabType StopTerm
+              logRefSuccess
               _ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
+              logRefSuccess
               _ <- Metrics.updateTree cId (Just listId) tabType MapTerm
-              pure ()
+              logRefSuccess
+
+              getRef
             _ -> do
               printDebug "[tableNgramsPut] no update for tabType = " tabType
-              pure ()
-          pure ()
-      pure ret
-     
+              pure $ jobLogFail $ jobLogInit 1
+
   {-
   { _ne_list        :: ListType
   If we merge the parents/children we can potentially create cycles!
@@ -624,6 +655,13 @@ type TableNgramsApi =  TableNgramsApiGet
                   :<|> TableNgramsApiPut
                   :<|> RecomputeScoresNgramsApiGet
                   :<|> "version" :> TableNgramsApiGetVersion
+                  :<|> TableNgramsAsyncApi
+
+type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
+                           :> "async"
+                           :> "charts"
+                           :> "update"
+                           :> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog
 
 getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
                => NodeId
@@ -671,35 +709,35 @@ getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orde
 
 
 
-apiNgramsTableCorpus :: ( RepoCmdM          env err m
-                        , HasNodeError          err
-                        , HasTreeError          err
-                        , HasInvalidError       err
-                        , HasConnectionPool env
-                        , HasConfig         env
-                        , HasSettings       env
+apiNgramsTableCorpus :: ( GargServerC env err m
                         )
                      => NodeId -> ServerT TableNgramsApi m
 apiNgramsTableCorpus cId =  getTableNgramsCorpus cId
                        :<|> tableNgramsPut
                        :<|> scoresRecomputeTableNgrams cId
                        :<|> getTableNgramsVersion cId
+                       :<|> apiNgramsAsync cId
 
-apiNgramsTableDoc :: ( RepoCmdM          env err m
-                     , HasNodeError          err
-                     , HasTreeError          err
-                     , HasInvalidError       err
-                     , HasConnectionPool env
-                     , HasConfig         env
-                     , HasSettings       env
+apiNgramsTableDoc :: ( GargServerC env err m
                      )
                   => DocId -> ServerT TableNgramsApi m
 apiNgramsTableDoc dId =  getTableNgramsDoc dId
                     :<|> tableNgramsPut
                     :<|> scoresRecomputeTableNgrams dId
                     :<|> getTableNgramsVersion dId
+                    :<|> apiNgramsAsync dId
                     -- > index all the corpus accordingly (TODO AD)
 
+apiNgramsAsync :: NodeId -> GargServer TableNgramsAsyncApi
+apiNgramsAsync _dId =
+  serveJobsAPI $
+    JobFunction $ \i log ->
+      let
+        log' x = do
+          printDebug "tableNgramsPostChartsAsync" x
+          liftBase $ log x
+      in tableNgramsPostChartsAsync i log'
+
 -- Did the given list of ngrams changed since the given version?
 -- The returned value is versioned boolean value, meaning that one always retrieve the
 -- latest version.

src/Gargantext/API/Ngrams/Types.hs

@@ -38,6 +38,7 @@ import Data.Validity
 import Database.PostgreSQL.Simple.FromField (FromField, fromField, ResultError(ConversionFailed), returnError)
 import GHC.Generics (Generic)
 import Servant hiding (Patch)
+import Servant.Job.Utils (jsonOptions)
 import System.FileLock (FileLock)
 import Test.QuickCheck (elements, frequency)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
@@ -46,7 +47,7 @@ import Protolude (maybeToEither)
 import Gargantext.Prelude
 
 import Gargantext.Core.Text (size)
-import Gargantext.Core.Types (ListType(..), NodeId)
+import Gargantext.Core.Types (ListType(..), ListId, NodeId)
 import Gargantext.Core.Types (TODO)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger, wellNamedSchema)
 import Gargantext.Database.Prelude (fromField', CmdM')
@@ -735,3 +736,17 @@ ngramsTypeFromTabType tabType =
       Terms      -> TableNgrams.NgramsTerms
       _          -> panic $ lieu <> "No Ngrams for this tab"
       -- TODO: This `panic` would disapear with custom NgramsType.
+
+----
+-- Async task
+
+data UpdateTableNgramsCharts = UpdateTableNgramsCharts
+  { _utn_tab_type :: !TabType
+  , _utn_list_id  :: !ListId
+  } deriving (Eq, Show, Generic)
+
+makeLenses ''UpdateTableNgramsCharts
+instance FromJSON UpdateTableNgramsCharts where
+  parseJSON = genericParseJSON $ jsonOptions "_utn_"
+instance ToSchema UpdateTableNgramsCharts where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_utn_")

src/Gargantext/API/Routes.hs

@@ -120,7 +120,8 @@ type GargPrivateAPI' =
            -- Document endpoint
            :<|> "document" :> Summary "Document endpoint"
                            :> Capture "doc_id" DocId
-                           :> "ngrams" :> TableNgramsApi
+                           :> "ngrams"
+                           :> TableNgramsApi
 
         -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI
             -- TODO-SECURITY

src/Gargantext/Prelude/Job.hs

+module Gargantext.Prelude.Job where
+
+import Data.IORef
+import Data.Maybe
+
+import Gargantext.Prelude
+
+import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
+
+
+jobLogInit :: Int -> JobLog
+jobLogInit rem =
+  JobLog { _scst_succeeded = Just 0
+         , _scst_remaining = Just rem
+         , _scst_failed = Just 0
+         , _scst_events = Just [] }
+
+jobLogSuccess :: JobLog -> JobLog
+jobLogSuccess (JobLog { _scst_succeeded = mSucc
+                      , _scst_remaining = mRem
+                      , _scst_failed = mFail
+                      , _scst_events = evt }) =
+  JobLog { _scst_succeeded = (+ 1) <$> mSucc
+         , _scst_remaining = (\x -> x - 1) <$> mRem
+         , _scst_failed = mFail
+         , _scst_events = evt }
+
+
+jobLogFail :: JobLog -> JobLog
+jobLogFail (JobLog { _scst_succeeded = mSucc
+                   , _scst_remaining = mRem
+                   , _scst_failed = mFail
+                   , _scst_events = evt }) =
+  JobLog { _scst_succeeded = mSucc
+         , _scst_remaining = (\x -> x - 1) <$> mRem
+         , _scst_failed = (+ 1) <$> mFail
+         , _scst_events = evt }
+
+runJobLog :: MonadBase IO m => Int -> (JobLog -> m ()) -> m (m (), m (), m JobLog)
+runJobLog num logStatus = do
+  jlRef <- liftBase $ newIORef $ jobLogInit num
+
+  return (logRefF jlRef, logRefSuccessF jlRef, getRefF jlRef)
+
+  where
+    logRefF ref = do
+      jl <- liftBase $ readIORef ref
+      logStatus jl
+    logRefSuccessF ref = do
+      jl <- liftBase $ readIORef ref
+      liftBase $ writeIORef ref $ jobLogSuccess jl
+    getRefF ref = do
+      liftBase $ readIORef ref