-{-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
{-|
Module : Gargantext.API.Ngrams
Description : Server API
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
where
import Control.Concurrent
-import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), sumOf, at, _Just, Each(..), (%%~), mapped)
+import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), sumOf, at, _Just, Each(..), (%%~), mapped, ifolded, withIndex)
import Control.Monad.Reader
import Data.Aeson hiding ((.=))
import qualified Data.Aeson.Text as DAT
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 Gargantext.Database.Admin.Config (userMaster)
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 Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Schema.Node (node_id, node_parentId, node_userId)
r <- liftBase $ readMVar var
pure $ r ^. r_version
+newNgramsFromNgramsStatePatch :: NgramsStatePatch -> [Ngrams]
+newNgramsFromNgramsStatePatch p =
+ [ text2ngrams (unNgramsTerm n)
+ | (n,np) <- p ^.. _PatchMap . each . _PatchMap . each . _NgramsTablePatch . _PatchMap . ifolded . withIndex
+ , _ <- np ^.. patch_new . _Just
+ ]
-- tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
commitStatePatch :: RepoCmdM env err m => Versioned NgramsStatePatch -> m (Versioned NgramsStatePatch)
pure ret
-tableNgramsPutAsync :: ( FlowCmdM env err m
- , HasSettings env
- )
- => UpdateTableNgrams
- -> (JobLog -> m ())
- -> m JobLog
-tableNgramsPutAsync utn logStatus = do
- -- let (Versioned p_version p_table) = utn ^. utn_patch
+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
case tabType of
Authors -> do
-- printDebug "[tableNgramsPut] Authors, updating Pie, cId" cId
- let jl = jobLogInit 1
- logStatus jl
+ (logRef, logRefSuccess, getRef) <- runJobLog 1 logStatus
+ logRef
_ <- Metrics.updatePie cId (Just listId) tabType Nothing
- pure $ jobLogSuccess jl
+ logRefSuccess
+
+ getRef
Institutes -> do
-- printDebug "[tableNgramsPut] Institutes, updating Tree, cId" cId
-- printDebug "[tableNgramsPut] updating tree StopTerm, cId" cId
- let jl = jobLogInit 3
- logStatus jl
+ (logRef, logRefSuccess, getRef) <- runJobLog 3 logStatus
+ logRef
_ <- Metrics.updateTree cId (Just listId) tabType StopTerm
-- printDebug "[tableNgramsPut] updating tree CandidateTerm, cId" cId
- let jl = jobLogSuccess jl
- logStatus jl
+ logRefSuccess
_ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
-- printDebug "[tableNgramsPut] updating tree MapTerm, cId" cId
- let jl = jobLogSuccess jl
- logStatus jl
+ logRefSuccess
_ <- Metrics.updateTree cId (Just listId) tabType MapTerm
- pure $ jobLogSuccess jl
+ logRefSuccess
+
+ getRef
Sources -> do
-- printDebug "[tableNgramsPut] Sources, updating chart, cId" cId
- let jl = jobLogInit 1
- logStatus jl
+ (logRef, logRefSuccess, getRef) <- runJobLog 1 logStatus
+ logRef
_ <- Metrics.updatePie cId (Just listId) tabType Nothing
- pure $ jobLogSuccess jl
+ logRefSuccess
+
+ getRef
Terms -> do
-- printDebug "[tableNgramsPut] Terms, updating Metrics (Histo), cId" cId
- let jl = jobLogInit 6
- logStatus jl
+ (logRef, logRefSuccess, getRef) <- runJobLog 6 logStatus
+ logRef
_ <- Metrics.updateChart cId (Just listId) tabType Nothing
- let jl = jobLogSuccess jl
- logStatus jl
+ logRefSuccess
_ <- Metrics.updatePie cId (Just listId) tabType Nothing
- let jl = jobLogSuccess jl
- logStatus jl
+ logRefSuccess
_ <- Metrics.updateScatter cId (Just listId) tabType Nothing
- let jl = jobLogSuccess jl
- logStatus jl
+ logRefSuccess
_ <- Metrics.updateTree cId (Just listId) tabType StopTerm
- let jl = jobLogSuccess jl
- logStatus jl
+ logRefSuccess
_ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
- let jl = jobLogSuccess jl
- logStatus jl
+ logRefSuccess
_ <- Metrics.updateTree cId (Just listId) tabType MapTerm
- pure $ jobLogSuccess jl
+ logRefSuccess
+
+ getRef
_ -> do
printDebug "[tableNgramsPut] no update for tabType = " tabType
pure $ jobLogFail $ jobLogInit 1
type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
:> "async"
+ :> "charts"
:> "update"
- :> AsyncJobs JobLog '[JSON] UpdateTableNgrams JobLog
+ :> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog
getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeId
apiNgramsAsync :: NodeId -> GargServer TableNgramsAsyncApi
apiNgramsAsync _dId =
serveJobsAPI $
- JobFunction (\i l ->
+ JobFunction $ \i log ->
let
log' x = do
- printDebug "tableNgramsPutAsync" x
- liftBase $ l x
- in tableNgramsPutAsync i log')
+ 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