-{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
{-|
Module : Gargantext.API.Ngrams
Description : Server API
-}
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
, r_history
, NgramsRepo
, NgramsRepoElement(..)
- , saveRepo
+ , saveNodeStory
, initRepo
, RepoEnv(..)
, TabType(..)
- , HasRepoVar(..)
- , HasRepoSaver(..)
- , HasRepo(..)
- , RepoCmdM
, QueryParamR
, TODO
, Version
, Versioned(..)
+ , VersionedWithCount(..)
, currentVersion
, listNgramsChangedSince
)
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 Data.Either (Either(..))
import Data.Foldable
-import qualified Data.List as List
import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import qualified Data.Map.Strict.Patch as PM
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Ord (Down(..))
import Data.Patch.Class (Action(act), Transformable(..), ours)
-import qualified Data.Set as S
-import qualified Data.Set as Set
import Data.Swagger hiding (version, patch)
import Data.Text (Text, isInfixOf, unpack)
import Data.Text.Lazy.IO as DTL
import Formatting (hprint, int, (%))
-import Formatting.Clock (timeSpecs)
import GHC.Generics (Generic)
-import Servant hiding (Patch)
-import System.Clock (getTime, TimeSpec, Clock(..))
-import System.IO (stderr)
-import Test.QuickCheck (elements)
-import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-
-import Prelude (error)
-import Gargantext.Prelude
-
+import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
-import qualified Gargantext.API.Metrics as Metrics
+import Gargantext.API.Job
import Gargantext.API.Ngrams.Types
-import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, HasInvalidError, TODO, assertValid)
-import Gargantext.Core.Utils (something)
--- import Gargantext.Core.Viz.Graph.API (recomputeGraph)
--- import Gargantext.Core.Viz.Graph.Distances (Distance(Conditional))
+import Gargantext.API.Prelude
+import Gargantext.Core.NodeStory
+import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, TODO, assertValid, HasInvalidError)
+import Gargantext.API.Ngrams.Tools
+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 qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
+import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngramsType, ngrams_terms)
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.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Database.Query.Table.Node.Select
+import Gargantext.Database.Schema.Node (node_id, node_parent_id, node_user_id)
+import Gargantext.Prelude hiding (log)
+import Gargantext.Prelude.Clock (hasTime, getTime)
+import Prelude (error)
+import Servant hiding (Patch)
+import Servant.Job.Async (JobFunction(..), serveJobsAPI)
+import System.IO (stderr)
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+import qualified Data.Aeson.Text as DAT
+import qualified Data.List as List
+import qualified Data.Map.Strict as Map
+import qualified Data.Map.Strict.Patch as PM
+import qualified Data.Set as S
+import qualified Data.Set as Set
+import qualified Gargantext.API.Metrics as Metrics
+import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
{-
-- TODO sequences of modifications (Patchs)
------------------------------------------------------------------------
-saveRepo :: ( MonadReader env m, MonadBase IO m, HasRepoSaver env )
+saveNodeStory :: ( MonadReader env m, MonadBase IO m, HasNodeStorySaver env )
=> m ()
-saveRepo = liftBase =<< view repoSaver
+saveNodeStory = liftBase =<< view hasNodeStorySaver
+
listTypeConflictResolution :: ListType -> ListType -> ListType
listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
+
ngramsStatePatchConflictResolution
:: TableNgrams.NgramsType
- -> NodeId
-> NgramsTerm
-> ConflictResolutionNgramsPatch
-ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
+ngramsStatePatchConflictResolution _ngramsType _ngramsTerm
= (ours, (const ours, ours), (False, False))
-- (False, False) mean here that Mod has always priority.
-- (True, False) <- would mean priority to the left (same as ours).
-
-- undefined {- TODO think this through -}, listTypeConflictResolution)
+
+
+
-- Current state:
-- Insertions are not considered as patches,
-- they do not extend history,
var <- view repoVar
liftBase $ modifyMVar_ var $
pure . (r_state . at ngramsType %~ (Just . f . something))
- saveRepo
+ saveNodeStory
where
f :: Map NodeId NgramsTableMap -> Map NodeId NgramsTableMap
f m = m & at dstListId %~ insertNewOnly (m ^. at srcListId)
var <- view repoVar
liftBase $ modifyMVar_ var $
pure . (r_state . at ngramsType . _Just . at listId . _Just <>~ m)
- saveRepo
+ saveNodeStory
where
m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
-}
--- UNSAFE
-rmListNgrams :: RepoCmdM env err m
- => ListId
- -> TableNgrams.NgramsType
- -> m ()
-rmListNgrams l nt = setListNgrams l nt mempty
-
-- | TODO: incr the Version number
-- && should use patch
-- UNSAFE
-setListNgrams :: RepoCmdM env err m
+
+setListNgrams :: HasNodeStory env err m
=> NodeId
-> TableNgrams.NgramsType
-> Map NgramsTerm NgramsRepoElement
-> m ()
setListNgrams listId ngramsType ns = do
- var <- view repoVar
+ printDebug "[setListNgrams]" (listId, ngramsType)
+ getter <- view hasNodeStory
+ var <- liftBase $ (getter ^. nse_getter) [listId]
liftBase $ modifyMVar_ var $
- pure . ( r_state
- . at ngramsType %~
- (Just .
- (at listId .~ ( Just ns))
- . something
- )
+ pure . ( unNodeStory
+ . at listId . _Just
+ . a_state
+ . at ngramsType
+ .~ Just ns
)
- saveRepo
+ saveNodeStory
-currentVersion :: RepoCmdM env err m
- => m Version
-currentVersion = do
- var <- view repoVar
- r <- liftBase $ readMVar var
- pure $ r ^. r_version
+currentVersion :: HasNodeStory env err m
+ => ListId -> m Version
+currentVersion listId = do
+ nls <- getRepo' [listId]
+ pure $ nls ^. unNodeStory . at listId . _Just . a_version
--- tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
-commitStatePatch :: RepoCmdM env err m => Versioned NgramsStatePatch -> m (Versioned NgramsStatePatch)
-commitStatePatch (Versioned p_version p) = do
- var <- view repoVar
- vq' <- liftBase $ modifyMVar var $ \r -> do
+newNgramsFromNgramsStatePatch :: NgramsStatePatch' -> [Ngrams]
+newNgramsFromNgramsStatePatch p =
+ [ text2ngrams (unNgramsTerm n)
+ | (n,np) <- p ^.. _PatchMap
+ -- . each . _PatchMap
+ . each . _NgramsTablePatch
+ . _PatchMap . ifolded . withIndex
+ , _ <- np ^.. patch_new . _Just
+ ]
+
+
+
+
+commitStatePatch :: HasNodeStory env err m
+ => ListId
+ -> Versioned NgramsStatePatch'
+ -> m (Versioned NgramsStatePatch')
+commitStatePatch listId (Versioned p_version p) = do
+ printDebug "[commitStatePatch]" listId
+ var <- getNodeStoryVar [listId]
+ vq' <- liftBase $ modifyMVar var $ \ns -> do
let
- q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
+ a = ns ^. unNodeStory . at listId . _Just
+ q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
(p', q') = transformWith ngramsStatePatchConflictResolution p q
- r' = r & r_version +~ 1
- & r_state %~ act p'
- & r_history %~ (p' :)
+ a' = a & a_version +~ 1
+ & a_state %~ act p'
+ & a_history %~ (p' :)
+
{-
-- Ideally we would like to check these properties. However:
-- * They should be checked only to debug the code. The client data
assertValid $ transformable p q
assertValid $ applicable p' (r ^. r_state)
-}
- pure (r', Versioned (r' ^. r_version) q')
+ printDebug "[commitStatePatch] a version" (a ^. a_version)
+ printDebug "[commitStatePatch] a' version" (a' ^. a_version)
+ pure ( ns & unNodeStory . at listId .~ (Just a')
+ , Versioned (a' ^. a_version) q'
+ )
+ saveNodeStory
+ -- Save new ngrams
+ _ <- insertNgrams (newNgramsFromNgramsStatePatch p)
- saveRepo
pure vq'
+
+
-- This is a special case of tableNgramsPut where the input patch is empty.
-tableNgramsPull :: RepoCmdM env err m
+tableNgramsPull :: HasNodeStory env err m
=> ListId
-> TableNgrams.NgramsType
-> Version
-> m (Versioned NgramsTablePatch)
tableNgramsPull listId ngramsType p_version = do
- var <- view repoVar
+ printDebug "[tableNgramsPull]" (listId, ngramsType)
+ var <- getNodeStoryVar [listId]
r <- liftBase $ readMVar var
let
- q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
- q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
+ a = r ^. unNodeStory . at listId . _Just
+ q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
+ q_table = q ^. _PatchMap . at ngramsType . _Just
+
+ pure (Versioned (a ^. a_version) q_table)
+
- pure (Versioned (r ^. r_version) q_table)
+
+-- tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
-- 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 :: ( HasNodeStory env err m
+ , HasInvalidError err
, HasSettings env
- , RepoCmdM env err m
)
=> TabType
-> ListId
-> m (Versioned NgramsTablePatch)
tableNgramsPut tabType listId (Versioned p_version p_table)
| p_table == mempty = do
+ printDebug "[tableNgramsPut]" ("TableEmpty" :: Text)
let ngramsType = ngramsTypeFromTabType tabType
tableNgramsPull listId ngramsType p_version
| otherwise = do
+ printDebug "[tableNgramsPut]" ("TableNonEmpty" :: Text)
let ngramsType = ngramsTypeFromTabType tabType
- (p0, p0_validity) = PM.singleton listId p_table
- (p, p_validity) = PM.singleton ngramsType p0
+ (p, p_validity) = PM.singleton ngramsType p_table
- assertValid p0_validity
assertValid p_validity
- ret <- commitStatePatch (Versioned p_version p)
- <&> v_data %~ (view (_PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just))
+ ret <- commitStatePatch listId (Versioned p_version p)
+ <&> v_data %~ (view (_PatchMap . at ngramsType . _Just))
+
+ pure ret
+
+
+
+tableNgramsPostChartsAsync :: ( HasNodeStory env err m
+ , 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
+ _uId = node ^. node_user_id
+ mCId = node ^. node_parent_id
- printDebug "[tableNgramsPut] tabType" tabType
- printDebug "[tableNgramsPut] listId" listId
+ -- printDebug "[tableNgramsPostChartsAsync] tabType" tabType
+ -- printDebug "[tableNgramsPostChartsAsync] listId" listId
- _ <- case mCId of
+ case mCId of
Nothing -> do
- printDebug "[tableNgramsPut] can't update charts, no parent, nId" nId
- pure ()
+ printDebug "[tableNgramsPostChartsAsync] can't update charts, no parent, nId" nId
+ pure $ jobLogFail $ jobLogInit 1
Just cId -> do
case tabType of
Authors -> do
- -- printDebug "[tableNgramsPut] Authors, updating Pie, cId" cId
+ -- printDebug "[tableNgramsPostChartsAsync] 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
+ -- printDebug "[tableNgramsPostChartsAsync] Institutes, updating Tree, cId" cId
+ -- printDebug "[tableNgramsPostChartsAsync] 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
+ -- printDebug "[tableNgramsPostChartsAsync] updating tree CandidateTerm, cId" cId
+ logRefSuccess
_ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
- -- printDebug "[tableNgramsPut] updating tree MapTerm, cId" cId
+ -- printDebug "[tableNgramsPostChartsAsync] 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
+ -- printDebug "[tableNgramsPostChartsAsync] 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
+ -- printDebug "[tableNgramsPostChartsAsync] 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
-
+ printDebug "[tableNgramsPostChartsAsync] no update for tabType = " tabType
+ pure $ jobLogFail $ jobLogInit 1
+
{-
{ _ne_list :: ListType
If we merge the parents/children we can potentially create cycles!
}
-}
-getNgramsTableMap :: RepoCmdM env err m
+getNgramsTableMap :: HasNodeStory env err m
=> NodeId
-> TableNgrams.NgramsType
-> m (Versioned NgramsTableMap)
getNgramsTableMap nodeId ngramsType = do
- v <- view repoVar
+ v <- getNodeStoryVar [nodeId]
repo <- liftBase $ readMVar v
- pure $ Versioned (repo ^. r_version)
- (repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
+ pure $ Versioned (repo ^. unNodeStory . at nodeId . _Just . a_version)
+ (repo ^. unNodeStory . at nodeId . _Just . a_state . at ngramsType . _Just)
-dumpJsonTableMap :: RepoCmdM env err m
+
+dumpJsonTableMap :: HasNodeStory env err m
=> Text
-> NodeId
-> TableNgrams.NgramsType
liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m)
pure ()
+
type MinSize = Int
type MaxSize = Int
-- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
-- TODO: should take only one ListId
-getTime' :: MonadBase IO m => m TimeSpec
-getTime' = liftBase $ getTime ProcessCPUTime
-
getTableNgrams :: forall env err m.
- (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
+ (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeType -> NodeId -> TabType
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
-> Maybe MinSize -> Maybe MaxSize
-> Maybe OrderBy
-> (NgramsTerm -> Bool)
- -> m (Versioned NgramsTable)
+ -> m (VersionedWithCount NgramsTable)
getTableNgrams _nType nId tabType listId limit_ offset
listType minSize maxSize orderBy searchQuery = do
- t0 <- getTime'
+ t0 <- getTime
-- lIds <- selectNodesWithUsername NodeList userMaster
let
ngramsType = ngramsTypeFromTabType tabType
sortOnOrder (Just ScoreAsc) = List.sortOn $ view ne_occurrences
sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view ne_occurrences
+ ---------------------------------------
+
+ filteredNodes :: Map NgramsTerm NgramsElement -> [NgramsElement]
+ filteredNodes tableMap = rootOf <$> list & filter selected_node
+ where
+ rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root")
+ (tableMap ^. at r)
+ )
+ (ne ^. ne_root)
+ list = tableMap ^.. each
+
---------------------------------------
selectAndPaginate :: Map NgramsTerm NgramsElement -> [NgramsElement]
selectAndPaginate tableMap = roots <> inners
where
list = tableMap ^.. each
- rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root") (tableMap ^. at r))
+ rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root")
+ (tableMap ^. at r)
+ )
(ne ^. ne_root)
selected_nodes = list & take limit_
. drop offset'
setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
setScores False table = pure table
setScores True table = do
- let ngrams_terms = unNgramsTerm <$> (table ^.. each . ne_ngrams)
- t1 <- getTime'
+ let ngrams_terms = table ^.. each . ne_ngrams
+ t1 <- getTime
occurrences <- getOccByNgramsOnlyFast' nId
listId
ngramsType
ngrams_terms
- t2 <- getTime'
+ t2 <- getTime
liftBase $ hprint stderr
- ("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
+ ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n")
(length ngrams_terms) t1 t2
{-
occurrences <- getOccByNgramsOnlySlow nType nId
ngrams_terms
-}
let
- setOcc ne = ne & ne_occurrences .~ sumOf (at (unNgramsTerm (ne ^. ne_ngrams)) . _Just) occurrences
+ setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
pure $ table & each %~ setOcc
---------------------------------------
-- trace (show lists) $
-- getNgramsTableMap ({-lists <>-} listIds) ngramsType
+
let scoresNeeded = needsScores orderBy
tableMap1 <- getNgramsTableMap listId ngramsType
- t1 <- getTime'
+ t1 <- getTime
tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
. Map.mapWithKey ngramsElementFromRepo
- t2 <- getTime'
+
+ fltr <- tableMap2 & v_data %%~ fmap NgramsTable . setScores (not scoresNeeded)
+ . filteredNodes
+ let fltrCount = length $ fltr ^. v_data . _NgramsTable
+
+ t2 <- getTime
tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
. setScores (not scoresNeeded)
. selectAndPaginate
- t3 <- getTime'
+ t3 <- getTime
liftBase $ hprint stderr
- ("getTableNgrams total=" % timeSpecs
- % " map1=" % timeSpecs
- % " map2=" % timeSpecs
- % " map3=" % timeSpecs
+ ("getTableNgrams total=" % hasTime
+ % " map1=" % hasTime
+ % " map2=" % hasTime
+ % " map3=" % hasTime
% " sql=" % (if scoresNeeded then "map2" else "map3")
% "\n"
) t0 t3 t0 t1 t1 t2 t2 t3
- pure tableMap3
+ pure $ toVersionedWithCount fltrCount tableMap3
+
-scoresRecomputeTableNgrams :: forall env err m. (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env) => NodeId -> TabType -> ListId -> m Int
+scoresRecomputeTableNgrams :: forall env err m.
+ (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
+ => NodeId -> TabType -> ListId -> m Int
scoresRecomputeTableNgrams nId tabType listId = do
tableMap <- getNgramsTableMap listId ngramsType
_ <- tableMap & v_data %%~ setScores
setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t
setScores table = do
- let ngrams_terms = unNgramsTerm <$> (table ^.. each . ne_ngrams)
+ let ngrams_terms = table ^.. each . ne_ngrams
occurrences <- getOccByNgramsOnlyFast' nId
listId
ngramsType
ngrams_terms
let
- setOcc ne = ne & ne_occurrences .~ sumOf (at (unNgramsTerm (ne ^. ne_ngrams)) . _Just) occurrences
+ setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
pure $ table & each %~ setOcc
+
-- APIs
-- TODO: find a better place for the code above, All APIs stay here
:> QueryParam "maxTermSize" MaxSize
:> QueryParam "orderBy" OrderBy
:> QueryParam "search" Text
- :> Get '[JSON] (Versioned NgramsTable)
+ :> Get '[JSON] (VersionedWithCount NgramsTable)
type TableNgramsApiPut = Summary " Table Ngrams API Change"
:> QueryParamR "ngramsType" TabType
:<|> 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)
+getTableNgramsCorpus :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeId
-> TabType
-> ListId
-> Maybe MinSize -> Maybe MaxSize
-> Maybe OrderBy
-> Maybe Text -- full text search
- -> m (Versioned NgramsTable)
+ -> m (VersionedWithCount NgramsTable)
getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
where
searchQuery (NgramsTerm nt) = maybe (const True) isInfixOf mt nt
-getTableNgramsVersion :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
+
+
+getTableNgramsVersion :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeId
-> TabType
-> ListId
-> m Version
-getTableNgramsVersion _nId _tabType _listId = currentVersion
+getTableNgramsVersion _nId _tabType listId = currentVersion listId
+
+
+
-- TODO: limit?
-- Versioned { _v_version = v } <- getTableNgramsCorpus nId tabType listId 100000 Nothing Nothing Nothing Nothing Nothing Nothing
-- This line above looks like a waste of computation to finally get only the version.
-- | Text search is deactivated for now for ngrams by doc only
-getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
+getTableNgramsDoc :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> DocId -> TabType
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
-> Maybe MinSize -> Maybe MaxSize
-> Maybe OrderBy
-> Maybe Text -- full text search
- -> m (Versioned NgramsTable)
+ -> m (VersionedWithCount NgramsTable)
getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do
ns <- selectNodesWithUsername NodeList userMaster
let ngramsType = ngramsTypeFromTabType tabType
-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
+apiNgramsTableCorpus cId = getTableNgramsCorpus cId
:<|> tableNgramsPut
:<|> scoresRecomputeTableNgrams cId
- :<|> getTableNgramsVersion cId
-
-apiNgramsTableDoc :: ( RepoCmdM env err m
- , HasNodeError err
- , HasTreeError err
- , HasInvalidError err
- , HasConnectionPool env
- , HasConfig env
- , HasSettings env
+ :<|> getTableNgramsVersion cId
+ :<|> apiNgramsAsync cId
+
+apiNgramsTableDoc :: ( GargServerC env err m
)
=> DocId -> ServerT TableNgramsApi m
-apiNgramsTableDoc dId = getTableNgramsDoc dId
+apiNgramsTableDoc dId = getTableNgramsDoc dId
:<|> tableNgramsPut
:<|> scoresRecomputeTableNgrams dId
- :<|> getTableNgramsVersion dId
- -- > index all the corpus accordingly (TODO AD)
+ :<|> getTableNgramsVersion dId
+ :<|> apiNgramsAsync dId
+
+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
-- * currentVersion: good computation, good bandwidth, bad precision.
-- * listNgramsChangedSince: good precision, good bandwidth, bad computation.
-- * tableNgramsPull: good precision, good bandwidth (if you use the received data!), bad computation.
-listNgramsChangedSince :: RepoCmdM env err m
+listNgramsChangedSince :: HasNodeStory env err m
=> ListId -> TableNgrams.NgramsType -> Version -> m (Versioned Bool)
listNgramsChangedSince listId ngramsType version
| version < 0 =
- Versioned <$> currentVersion <*> pure True
+ Versioned <$> currentVersion listId <*> pure True
| otherwise =
tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
+
+