]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Ngrams.hs
[CLEAN] renaming unexplicit fun
[gargantext.git] / src / Gargantext / API / Ngrams.hs
1 {-|
2 Module : Gargantext.API.Ngrams
3 Description : Server API
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 Ngrams API
11
12 -- | TODO
13 get ngrams filtered by NgramsType
14 add get
15
16 -}
17
18 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
19
20 {-# LANGUAGE ConstraintKinds #-}
21 {-# LANGUAGE ScopedTypeVariables #-}
22 {-# LANGUAGE TypeOperators #-}
23 {-# LANGUAGE TypeFamilies #-}
24
25 module Gargantext.API.Ngrams
26 ( TableNgramsApi
27 , TableNgramsApiGet
28 , TableNgramsApiPut
29
30 , getTableNgrams
31 , setListNgrams
32 --, rmListNgrams TODO fix before exporting
33 , apiNgramsTableCorpus
34 , apiNgramsTableDoc
35
36 , NgramsStatePatch
37 , NgramsTablePatch
38 , NgramsTableMap
39
40 , NgramsTerm(..)
41
42 , NgramsElement(..)
43 , mkNgramsElement
44
45 , RootParent(..)
46
47 , MSet
48 , mSetFromList
49 , mSetToList
50
51 , Repo(..)
52 , r_version
53 , r_state
54 , r_history
55 , NgramsRepo
56 , NgramsRepoElement(..)
57 , saveRepo
58 , initRepo
59
60 , RepoEnv(..)
61 , renv_var
62 , renv_lock
63
64 , TabType(..)
65
66 , HasRepoVar(..)
67 , HasRepoSaver(..)
68 , HasRepo(..)
69 , RepoCmdM
70 , QueryParamR
71 , TODO
72
73 -- Internals
74 , getNgramsTableMap
75 , dumpJsonTableMap
76 , tableNgramsPull
77 , tableNgramsPut
78
79 , Version
80 , Versioned(..)
81 , currentVersion
82 , listNgramsChangedSince
83 )
84 where
85
86 import Control.Concurrent
87 import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), sumOf, at, _Just, Each(..), (%%~), mapped, ifolded, withIndex)
88 import Control.Monad.Reader
89 import Data.Aeson hiding ((.=))
90 import qualified Data.Aeson.Text as DAT
91 import Data.Either (Either(..))
92 import Data.Foldable
93 import qualified Data.List as List
94 import Data.Map.Strict (Map)
95 import qualified Data.Map.Strict as Map
96 import qualified Data.Map.Strict.Patch as PM
97 import Data.Maybe (fromMaybe)
98 import Data.Monoid
99 import Data.Ord (Down(..))
100 import Data.Patch.Class (Action(act), Transformable(..), ours)
101 import qualified Data.Set as S
102 import qualified Data.Set as Set
103 import Data.Swagger hiding (version, patch)
104 import Data.Text (Text, isInfixOf, unpack)
105 import Data.Text.Lazy.IO as DTL
106 import Formatting (hprint, int, (%))
107 import Formatting.Clock (timeSpecs)
108 import GHC.Generics (Generic)
109 import Servant hiding (Patch)
110 import System.Clock (getTime, TimeSpec, Clock(..))
111 import Servant.Job.Async (JobFunction(..), serveJobsAPI)
112 import System.IO (stderr)
113 import Test.QuickCheck (elements)
114 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
115
116 import Prelude (error)
117 import Gargantext.Prelude hiding (log)
118
119 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
120 import Gargantext.API.Admin.Types (HasSettings)
121 import qualified Gargantext.API.Metrics as Metrics
122 import Gargantext.API.Ngrams.Types
123 import Gargantext.API.Prelude
124 import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, TODO, assertValid)
125 import Gargantext.Core.Utils (something)
126 -- import Gargantext.Core.Viz.Graph.API (recomputeGraph)
127 -- import Gargantext.Core.Viz.Graph.Distances (Distance(Conditional))
128 import Gargantext.Database.Action.Flow.Types
129 import Gargantext.Database.Action.Metrics.NgramsByNode (getOccByNgramsOnlyFast')
130 import Gargantext.Database.Admin.Config (userMaster)
131 import Gargantext.Database.Admin.Types.Node (NodeType(..))
132 import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
133 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
134 import Gargantext.Database.Query.Table.Node.Select
135 import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngrams, ngramsType, ngrams_terms)
136 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
137 import Gargantext.Database.Query.Table.Node (getNode)
138 import Gargantext.Database.Schema.Node (node_id, node_parentId, node_userId)
139 import Gargantext.Prelude.Job
140
141 {-
142 -- TODO sequences of modifications (Patchs)
143 type NgramsIdPatch = Patch NgramsId NgramsPatch
144
145 ngramsPatch :: Int -> NgramsPatch
146 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopTerm)]) (Set.fromList [n]) Set.empty
147
148 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
149 toEdit n p = Edit n p
150 ngramsIdPatch :: Patch NgramsId NgramsPatch
151 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
152 , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
153 , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
154 ]
155
156 -- applyPatchBack :: Patch -> IO Patch
157 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
158 -}
159 ------------------------------------------------------------------------
160 ------------------------------------------------------------------------
161 ------------------------------------------------------------------------
162
163 {-
164 -- TODO: Replace.old is ignored which means that if the current list
165 -- `MapTerm` and that the patch is `Replace CandidateTerm StopTerm` then
166 -- the list is going to be `StopTerm` while it should keep `MapTerm`.
167 -- However this should not happen in non conflicting situations.
168 mkListsUpdate :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)]
169 mkListsUpdate nt patches =
170 [ (ngramsTypeId nt, ng, listTypeId lt)
171 | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
172 , lt <- patch ^.. patch_list . new
173 ]
174
175 mkChildrenGroups :: (PatchSet NgramsTerm -> Set NgramsTerm)
176 -> NgramsType
177 -> NgramsTablePatch
178 -> [(NgramsTypeId, NgramsParent, NgramsChild)]
179 mkChildrenGroups addOrRem nt patches =
180 [ (ngramsTypeId nt, parent, child)
181 | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
182 , child <- patch ^.. patch_children . to addOrRem . folded
183 ]
184 -}
185
186 ------------------------------------------------------------------------
187
188 saveRepo :: ( MonadReader env m, MonadBase IO m, HasRepoSaver env )
189 => m ()
190 saveRepo = liftBase =<< view repoSaver
191
192 listTypeConflictResolution :: ListType -> ListType -> ListType
193 listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
194
195 ngramsStatePatchConflictResolution
196 :: TableNgrams.NgramsType
197 -> NodeId
198 -> NgramsTerm
199 -> ConflictResolutionNgramsPatch
200 ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
201 = (ours, (const ours, ours), (False, False))
202 -- (False, False) mean here that Mod has always priority.
203 -- (True, False) <- would mean priority to the left (same as ours).
204
205 -- undefined {- TODO think this through -}, listTypeConflictResolution)
206
207 -- Current state:
208 -- Insertions are not considered as patches,
209 -- they do not extend history,
210 -- they do not bump version.
211 insertNewOnly :: a -> Maybe b -> a
212 insertNewOnly m = maybe m (const $ error "insertNewOnly: impossible")
213 -- TODO error handling
214
215 {- unused
216 -- TODO refactor with putListNgrams
217 copyListNgrams :: RepoCmdM env err m
218 => NodeId -> NodeId -> NgramsType
219 -> m ()
220 copyListNgrams srcListId dstListId ngramsType = do
221 var <- view repoVar
222 liftBase $ modifyMVar_ var $
223 pure . (r_state . at ngramsType %~ (Just . f . something))
224 saveRepo
225 where
226 f :: Map NodeId NgramsTableMap -> Map NodeId NgramsTableMap
227 f m = m & at dstListId %~ insertNewOnly (m ^. at srcListId)
228
229 -- TODO refactor with putListNgrams
230 -- The list must be non-empty!
231 -- The added ngrams must be non-existent!
232 addListNgrams :: RepoCmdM env err m
233 => NodeId -> NgramsType
234 -> [NgramsElement] -> m ()
235 addListNgrams listId ngramsType nes = do
236 var <- view repoVar
237 liftBase $ modifyMVar_ var $
238 pure . (r_state . at ngramsType . _Just . at listId . _Just <>~ m)
239 saveRepo
240 where
241 m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
242 -}
243
244 -- UNSAFE
245 rmListNgrams :: RepoCmdM env err m
246 => ListId
247 -> TableNgrams.NgramsType
248 -> m ()
249 rmListNgrams l nt = setListNgrams l nt mempty
250
251 -- | TODO: incr the Version number
252 -- && should use patch
253 -- UNSAFE
254 setListNgrams :: RepoCmdM env err m
255 => NodeId
256 -> TableNgrams.NgramsType
257 -> Map NgramsTerm NgramsRepoElement
258 -> m ()
259 setListNgrams listId ngramsType ns = do
260 var <- view repoVar
261 liftBase $ modifyMVar_ var $
262 pure . ( r_state
263 . at ngramsType %~
264 (Just .
265 (at listId .~ ( Just ns))
266 . something
267 )
268 )
269 saveRepo
270
271
272 currentVersion :: RepoCmdM env err m
273 => m Version
274 currentVersion = do
275 var <- view repoVar
276 r <- liftBase $ readMVar var
277 pure $ r ^. r_version
278
279 newNgramsFromNgramsStatePatch :: NgramsStatePatch -> [Ngrams]
280 newNgramsFromNgramsStatePatch p =
281 [ text2ngrams (unNgramsTerm n)
282 | (n,np) <- p ^.. _PatchMap . each . _PatchMap . each . _NgramsTablePatch . _PatchMap . ifolded . withIndex
283 , _ <- np ^.. patch_new . _Just
284 ]
285
286 -- tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
287 commitStatePatch :: RepoCmdM env err m => Versioned NgramsStatePatch -> m (Versioned NgramsStatePatch)
288 commitStatePatch (Versioned p_version p) = do
289 var <- view repoVar
290 vq' <- liftBase $ modifyMVar var $ \r -> do
291 let
292 q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
293 (p', q') = transformWith ngramsStatePatchConflictResolution p q
294 r' = r & r_version +~ 1
295 & r_state %~ act p'
296 & r_history %~ (p' :)
297 {-
298 -- Ideally we would like to check these properties. However:
299 -- * They should be checked only to debug the code. The client data
300 -- should be able to trigger these.
301 -- * What kind of error should they throw (we are in IO here)?
302 -- * Should we keep modifyMVar?
303 -- * Should we throw the validation in an Exception, catch it around
304 -- modifyMVar and throw it back as an Error?
305 assertValid $ transformable p q
306 assertValid $ applicable p' (r ^. r_state)
307 -}
308 pure (r', Versioned (r' ^. r_version) q')
309
310 saveRepo
311
312 -- Save new ngrams
313 _ <- insertNgrams (newNgramsFromNgramsStatePatch p)
314
315 pure vq'
316
317 -- This is a special case of tableNgramsPut where the input patch is empty.
318 tableNgramsPull :: RepoCmdM env err m
319 => ListId
320 -> TableNgrams.NgramsType
321 -> Version
322 -> m (Versioned NgramsTablePatch)
323 tableNgramsPull listId ngramsType p_version = do
324 var <- view repoVar
325 r <- liftBase $ readMVar var
326
327 let
328 q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
329 q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
330
331 pure (Versioned (r ^. r_version) q_table)
332
333 -- Apply the given patch to the DB and returns the patch to be applied on the
334 -- client.
335 -- TODO-ACCESS check
336 tableNgramsPut :: ( FlowCmdM env err m
337 , HasSettings env
338 )
339 => TabType
340 -> ListId
341 -> Versioned NgramsTablePatch
342 -> m (Versioned NgramsTablePatch)
343 tableNgramsPut tabType listId (Versioned p_version p_table)
344 | p_table == mempty = do
345 let ngramsType = ngramsTypeFromTabType tabType
346 tableNgramsPull listId ngramsType p_version
347
348 | otherwise = do
349 let ngramsType = ngramsTypeFromTabType tabType
350 (p0, p0_validity) = PM.singleton listId p_table
351 (p, p_validity) = PM.singleton ngramsType p0
352
353 assertValid p0_validity
354 assertValid p_validity
355
356 ret <- commitStatePatch (Versioned p_version p)
357 <&> v_data %~ (view (_PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just))
358
359 pure ret
360
361
362 tableNgramsPostChartsAsync :: ( FlowCmdM env err m
363 , HasNodeError err
364 , HasSettings env
365 )
366 => UpdateTableNgramsCharts
367 -> (JobLog -> m ())
368 -> m JobLog
369 tableNgramsPostChartsAsync utn logStatus = do
370 let tabType = utn ^. utn_tab_type
371 let listId = utn ^. utn_list_id
372
373 node <- getNode listId
374 let nId = node ^. node_id
375 _uId = node ^. node_userId
376 mCId = node ^. node_parentId
377
378 printDebug "[tableNgramsPut] tabType" tabType
379 printDebug "[tableNgramsPut] listId" listId
380
381 case mCId of
382 Nothing -> do
383 printDebug "[tableNgramsPut] can't update charts, no parent, nId" nId
384 pure $ jobLogFail $ jobLogInit 1
385 Just cId -> do
386 case tabType of
387 Authors -> do
388 -- printDebug "[tableNgramsPut] Authors, updating Pie, cId" cId
389 (logRef, logRefSuccess, getRef) <- runJobLog 1 logStatus
390 logRef
391 _ <- Metrics.updatePie cId (Just listId) tabType Nothing
392 logRefSuccess
393
394 getRef
395 Institutes -> do
396 -- printDebug "[tableNgramsPut] Institutes, updating Tree, cId" cId
397 -- printDebug "[tableNgramsPut] updating tree StopTerm, cId" cId
398 (logRef, logRefSuccess, getRef) <- runJobLog 3 logStatus
399 logRef
400 _ <- Metrics.updateTree cId (Just listId) tabType StopTerm
401 -- printDebug "[tableNgramsPut] updating tree CandidateTerm, cId" cId
402 logRefSuccess
403 _ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
404 -- printDebug "[tableNgramsPut] updating tree MapTerm, cId" cId
405 logRefSuccess
406 _ <- Metrics.updateTree cId (Just listId) tabType MapTerm
407 logRefSuccess
408
409 getRef
410 Sources -> do
411 -- printDebug "[tableNgramsPut] Sources, updating chart, cId" cId
412 (logRef, logRefSuccess, getRef) <- runJobLog 1 logStatus
413 logRef
414 _ <- Metrics.updatePie cId (Just listId) tabType Nothing
415 logRefSuccess
416
417 getRef
418 Terms -> do
419 -- printDebug "[tableNgramsPut] Terms, updating Metrics (Histo), cId" cId
420 (logRef, logRefSuccess, getRef) <- runJobLog 6 logStatus
421 logRef
422 _ <- Metrics.updateChart cId (Just listId) tabType Nothing
423 logRefSuccess
424 _ <- Metrics.updatePie cId (Just listId) tabType Nothing
425 logRefSuccess
426 _ <- Metrics.updateScatter cId (Just listId) tabType Nothing
427 logRefSuccess
428 _ <- Metrics.updateTree cId (Just listId) tabType StopTerm
429 logRefSuccess
430 _ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
431 logRefSuccess
432 _ <- Metrics.updateTree cId (Just listId) tabType MapTerm
433 logRefSuccess
434
435 getRef
436 _ -> do
437 printDebug "[tableNgramsPut] no update for tabType = " tabType
438 pure $ jobLogFail $ jobLogInit 1
439
440 {-
441 { _ne_list :: ListType
442 If we merge the parents/children we can potentially create cycles!
443 , _ne_parent :: Maybe NgramsTerm
444 , _ne_children :: MSet NgramsTerm
445 }
446 -}
447
448 getNgramsTableMap :: RepoCmdM env err m
449 => NodeId
450 -> TableNgrams.NgramsType
451 -> m (Versioned NgramsTableMap)
452 getNgramsTableMap nodeId ngramsType = do
453 v <- view repoVar
454 repo <- liftBase $ readMVar v
455 pure $ Versioned (repo ^. r_version)
456 (repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
457
458 dumpJsonTableMap :: RepoCmdM env err m
459 => Text
460 -> NodeId
461 -> TableNgrams.NgramsType
462 -> m ()
463 dumpJsonTableMap fpath nodeId ngramsType = do
464 m <- getNgramsTableMap nodeId ngramsType
465 liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m)
466 pure ()
467
468 type MinSize = Int
469 type MaxSize = Int
470
471 -- | TODO Errors management
472 -- TODO: polymorphic for Annuaire or Corpus or ...
473 -- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
474 -- TODO: should take only one ListId
475
476 getTime' :: MonadBase IO m => m TimeSpec
477 getTime' = liftBase $ getTime ProcessCPUTime
478
479
480 getTableNgrams :: forall env err m.
481 (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
482 => NodeType -> NodeId -> TabType
483 -> ListId -> Limit -> Maybe Offset
484 -> Maybe ListType
485 -> Maybe MinSize -> Maybe MaxSize
486 -> Maybe OrderBy
487 -> (NgramsTerm -> Bool)
488 -> m (Versioned NgramsTable)
489 getTableNgrams _nType nId tabType listId limit_ offset
490 listType minSize maxSize orderBy searchQuery = do
491
492 t0 <- getTime'
493 -- lIds <- selectNodesWithUsername NodeList userMaster
494 let
495 ngramsType = ngramsTypeFromTabType tabType
496 offset' = maybe 0 identity offset
497 listType' = maybe (const True) (==) listType
498 minSize' = maybe (const True) (<=) minSize
499 maxSize' = maybe (const True) (>=) maxSize
500
501 selected_node n = minSize' s
502 && maxSize' s
503 && searchQuery (n ^. ne_ngrams)
504 && listType' (n ^. ne_list)
505 where
506 s = n ^. ne_size
507
508 selected_inner roots n = maybe False (`Set.member` roots) (n ^. ne_root)
509
510 ---------------------------------------
511 sortOnOrder Nothing = identity
512 sortOnOrder (Just TermAsc) = List.sortOn $ view ne_ngrams
513 sortOnOrder (Just TermDesc) = List.sortOn $ Down . view ne_ngrams
514 sortOnOrder (Just ScoreAsc) = List.sortOn $ view ne_occurrences
515 sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view ne_occurrences
516
517 ---------------------------------------
518 selectAndPaginate :: Map NgramsTerm NgramsElement -> [NgramsElement]
519 selectAndPaginate tableMap = roots <> inners
520 where
521 list = tableMap ^.. each
522 rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root") (tableMap ^. at r))
523 (ne ^. ne_root)
524 selected_nodes = list & take limit_
525 . drop offset'
526 . filter selected_node
527 . sortOnOrder orderBy
528 roots = rootOf <$> selected_nodes
529 rootsSet = Set.fromList (_ne_ngrams <$> roots)
530 inners = list & filter (selected_inner rootsSet)
531
532 ---------------------------------------
533 setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
534 setScores False table = pure table
535 setScores True table = do
536 let ngrams_terms = unNgramsTerm <$> (table ^.. each . ne_ngrams)
537 t1 <- getTime'
538 occurrences <- getOccByNgramsOnlyFast' nId
539 listId
540 ngramsType
541 ngrams_terms
542 t2 <- getTime'
543 liftBase $ hprint stderr
544 ("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
545 (length ngrams_terms) t1 t2
546 {-
547 occurrences <- getOccByNgramsOnlySlow nType nId
548 (lIds <> [listId])
549 ngramsType
550 ngrams_terms
551 -}
552 let
553 setOcc ne = ne & ne_occurrences .~ sumOf (at (unNgramsTerm (ne ^. ne_ngrams)) . _Just) occurrences
554
555 pure $ table & each %~ setOcc
556 ---------------------------------------
557
558 -- lists <- catMaybes <$> listsWith userMaster
559 -- trace (show lists) $
560 -- getNgramsTableMap ({-lists <>-} listIds) ngramsType
561
562 let scoresNeeded = needsScores orderBy
563 tableMap1 <- getNgramsTableMap listId ngramsType
564 t1 <- getTime'
565 tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
566 . Map.mapWithKey ngramsElementFromRepo
567 t2 <- getTime'
568 tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
569 . setScores (not scoresNeeded)
570 . selectAndPaginate
571 t3 <- getTime'
572 liftBase $ hprint stderr
573 ("getTableNgrams total=" % timeSpecs
574 % " map1=" % timeSpecs
575 % " map2=" % timeSpecs
576 % " map3=" % timeSpecs
577 % " sql=" % (if scoresNeeded then "map2" else "map3")
578 % "\n"
579 ) t0 t3 t0 t1 t1 t2 t2 t3
580 pure tableMap3
581
582
583 scoresRecomputeTableNgrams :: forall env err m. (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env) => NodeId -> TabType -> ListId -> m Int
584 scoresRecomputeTableNgrams nId tabType listId = do
585 tableMap <- getNgramsTableMap listId ngramsType
586 _ <- tableMap & v_data %%~ setScores
587 . Map.mapWithKey ngramsElementFromRepo
588
589 pure $ 1
590 where
591 ngramsType = ngramsTypeFromTabType tabType
592
593 setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t
594 setScores table = do
595 let ngrams_terms = unNgramsTerm <$> (table ^.. each . ne_ngrams)
596 occurrences <- getOccByNgramsOnlyFast' nId
597 listId
598 ngramsType
599 ngrams_terms
600 let
601 setOcc ne = ne & ne_occurrences .~ sumOf (at (unNgramsTerm (ne ^. ne_ngrams)) . _Just) occurrences
602
603 pure $ table & each %~ setOcc
604
605
606
607 -- APIs
608
609 -- TODO: find a better place for the code above, All APIs stay here
610
611 data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
612 deriving (Generic, Enum, Bounded, Read, Show)
613
614 instance FromHttpApiData OrderBy
615 where
616 parseUrlPiece "TermAsc" = pure TermAsc
617 parseUrlPiece "TermDesc" = pure TermDesc
618 parseUrlPiece "ScoreAsc" = pure ScoreAsc
619 parseUrlPiece "ScoreDesc" = pure ScoreDesc
620 parseUrlPiece _ = Left "Unexpected value of OrderBy"
621
622
623 instance ToParamSchema OrderBy
624 instance FromJSON OrderBy
625 instance ToJSON OrderBy
626 instance ToSchema OrderBy
627 instance Arbitrary OrderBy
628 where
629 arbitrary = elements [minBound..maxBound]
630
631 needsScores :: Maybe OrderBy -> Bool
632 needsScores (Just ScoreAsc) = True
633 needsScores (Just ScoreDesc) = True
634 needsScores _ = False
635
636 type TableNgramsApiGet = Summary " Table Ngrams API Get"
637 :> QueryParamR "ngramsType" TabType
638 :> QueryParamR "list" ListId
639 :> QueryParamR "limit" Limit
640 :> QueryParam "offset" Offset
641 :> QueryParam "listType" ListType
642 :> QueryParam "minTermSize" MinSize
643 :> QueryParam "maxTermSize" MaxSize
644 :> QueryParam "orderBy" OrderBy
645 :> QueryParam "search" Text
646 :> Get '[JSON] (Versioned NgramsTable)
647
648 type TableNgramsApiPut = Summary " Table Ngrams API Change"
649 :> QueryParamR "ngramsType" TabType
650 :> QueryParamR "list" ListId
651 :> ReqBody '[JSON] (Versioned NgramsTablePatch)
652 :> Put '[JSON] (Versioned NgramsTablePatch)
653
654 type RecomputeScoresNgramsApiGet = Summary " Recompute scores for ngrams table"
655 :> QueryParamR "ngramsType" TabType
656 :> QueryParamR "list" ListId
657 :> "recompute" :> Post '[JSON] Int
658
659 type TableNgramsApiGetVersion = Summary " Table Ngrams API Get Version"
660 :> QueryParamR "ngramsType" TabType
661 :> QueryParamR "list" ListId
662 :> Get '[JSON] Version
663
664 type TableNgramsApi = TableNgramsApiGet
665 :<|> TableNgramsApiPut
666 :<|> RecomputeScoresNgramsApiGet
667 :<|> "version" :> TableNgramsApiGetVersion
668 :<|> TableNgramsAsyncApi
669
670 type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
671 :> "async"
672 :> "charts"
673 :> "update"
674 :> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog
675
676 getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
677 => NodeId
678 -> TabType
679 -> ListId
680 -> Limit
681 -> Maybe Offset
682 -> Maybe ListType
683 -> Maybe MinSize -> Maybe MaxSize
684 -> Maybe OrderBy
685 -> Maybe Text -- full text search
686 -> m (Versioned NgramsTable)
687 getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
688 getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
689 where
690 searchQuery (NgramsTerm nt) = maybe (const True) isInfixOf mt nt
691
692 getTableNgramsVersion :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
693 => NodeId
694 -> TabType
695 -> ListId
696 -> m Version
697 getTableNgramsVersion _nId _tabType _listId = currentVersion
698 -- TODO: limit?
699 -- Versioned { _v_version = v } <- getTableNgramsCorpus nId tabType listId 100000 Nothing Nothing Nothing Nothing Nothing Nothing
700 -- This line above looks like a waste of computation to finally get only the version.
701 -- See the comment about listNgramsChangedSince.
702
703
704 -- | Text search is deactivated for now for ngrams by doc only
705 getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
706 => DocId -> TabType
707 -> ListId -> Limit -> Maybe Offset
708 -> Maybe ListType
709 -> Maybe MinSize -> Maybe MaxSize
710 -> Maybe OrderBy
711 -> Maybe Text -- full text search
712 -> m (Versioned NgramsTable)
713 getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do
714 ns <- selectNodesWithUsername NodeList userMaster
715 let ngramsType = ngramsTypeFromTabType tabType
716 ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
717 let searchQuery (NgramsTerm nt) = flip S.member (S.fromList ngs) nt
718 getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
719
720
721
722 apiNgramsTableCorpus :: ( GargServerC env err m
723 )
724 => NodeId -> ServerT TableNgramsApi m
725 apiNgramsTableCorpus cId = getTableNgramsCorpus cId
726 :<|> tableNgramsPut
727 :<|> scoresRecomputeTableNgrams cId
728 :<|> getTableNgramsVersion cId
729 :<|> apiNgramsAsync cId
730
731 apiNgramsTableDoc :: ( GargServerC env err m
732 )
733 => DocId -> ServerT TableNgramsApi m
734 apiNgramsTableDoc dId = getTableNgramsDoc dId
735 :<|> tableNgramsPut
736 :<|> scoresRecomputeTableNgrams dId
737 :<|> getTableNgramsVersion dId
738 :<|> apiNgramsAsync dId
739 -- > index all the corpus accordingly (TODO AD)
740
741 apiNgramsAsync :: NodeId -> GargServer TableNgramsAsyncApi
742 apiNgramsAsync _dId =
743 serveJobsAPI $
744 JobFunction $ \i log ->
745 let
746 log' x = do
747 printDebug "tableNgramsPostChartsAsync" x
748 liftBase $ log x
749 in tableNgramsPostChartsAsync i log'
750
751 -- Did the given list of ngrams changed since the given version?
752 -- The returned value is versioned boolean value, meaning that one always retrieve the
753 -- latest version.
754 -- If the given version is negative then one simply receive the latest version and True.
755 -- Using this function is more precise than simply comparing the latest version number
756 -- with the local version number. Indeed there might be no change to this particular list
757 -- and still the version number has changed because of other lists.
758 --
759 -- Here the added value is to make a compromise between precision, computation, and bandwidth:
760 -- * currentVersion: good computation, good bandwidth, bad precision.
761 -- * listNgramsChangedSince: good precision, good bandwidth, bad computation.
762 -- * tableNgramsPull: good precision, good bandwidth (if you use the received data!), bad computation.
763 listNgramsChangedSince :: RepoCmdM env err m
764 => ListId -> TableNgrams.NgramsType -> Version -> m (Versioned Bool)
765 listNgramsChangedSince listId ngramsType version
766 | version < 0 =
767 Versioned <$> currentVersion <*> pure True
768 | otherwise =
769 tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)