]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Ngrams.hs
seuil
[gargantext.git] / src / Gargantext / API / Ngrams.hs
1 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
2 {-|
3 Module : Gargantext.API.Ngrams
4 Description : Server API
5 Copyright : (c) CNRS, 2017-Present
6 License : AGPL + CECILL v3
7 Maintainer : team@gargantext.org
8 Stability : experimental
9 Portability : POSIX
10
11 Ngrams API
12
13 -- | TODO
14 get ngrams filtered by NgramsType
15 add get
16
17 -}
18
19 {-# LANGUAGE ConstraintKinds #-}
20 {-# LANGUAGE DataKinds #-}
21 {-# LANGUAGE DeriveGeneric #-}
22 {-# LANGUAGE NoImplicitPrelude #-}
23 {-# LANGUAGE OverloadedStrings #-}
24 {-# LANGUAGE ScopedTypeVariables #-}
25 {-# LANGUAGE TemplateHaskell #-}
26 {-# LANGUAGE TypeOperators #-}
27 {-# LANGUAGE FlexibleContexts #-}
28 {-# LANGUAGE FlexibleInstances #-}
29 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
30 {-# LANGUAGE MultiParamTypeClasses #-}
31 {-# LANGUAGE RankNTypes #-}
32 {-# LANGUAGE TypeFamilies #-}
33 {-# OPTIONS -fno-warn-orphans #-}
34
35 module Gargantext.API.Ngrams
36 ( TableNgramsApi
37 , TableNgramsApiGet
38 , TableNgramsApiPut
39 , TableNgramsApiPost
40
41 , getTableNgrams
42 , putListNgrams
43 , tableNgramsPost
44 , apiNgramsTableCorpus
45 , apiNgramsTableDoc
46
47 , NgramsStatePatch
48 , NgramsTablePatch
49
50 , NgramsElement(..)
51 , mkNgramsElement
52 , mergeNgramsElement
53
54 , RootParent(..)
55
56 , MSet
57 , mSetFromList
58 , mSetToList
59
60 , Repo(..)
61 , r_version
62 , r_state
63 , r_history
64 , NgramsRepo
65 , NgramsRepoElement(..)
66 , saveRepo
67 , initRepo
68
69 , RepoEnv(..)
70 , renv_var
71 , renv_lock
72
73 , TabType(..)
74 , ngramsTypeFromTabType
75
76 , HasRepoVar(..)
77 , HasRepoSaver(..)
78 , HasRepo(..)
79 , RepoCmdM
80 , QueryParamR
81 , TODO
82
83 -- Internals
84 , getNgramsTableMap
85 , tableNgramsPull
86 , tableNgramsPut
87
88 , Versioned(..)
89 , currentVersion
90 , listNgramsChangedSince
91 )
92 where
93
94 -- import Debug.Trace (trace)
95 import Prelude (Enum, Bounded, Semigroup(..), minBound, maxBound {-, round-}, error)
96 -- import Gargantext.Database.Schema.User (UserId)
97 import Data.Patch.Class (Replace, replace, Action(act), Applicable(..),
98 Composable(..), Transformable(..),
99 PairPatch(..), Patched, ConflictResolution,
100 ConflictResolutionReplace, ours)
101 import qualified Data.Map.Strict.Patch as PM
102 import Data.Monoid
103 import Data.Ord (Down(..))
104 import Data.Foldable
105 --import Data.Semigroup
106 import Data.Set (Set)
107 import qualified Data.Set as S
108 import qualified Data.List as List
109 import Data.Maybe (fromMaybe)
110 -- import Data.Tuple.Extra (first)
111 import qualified Data.Map.Strict as Map
112 import Data.Map.Strict (Map)
113 import qualified Data.Set as Set
114 import Control.Category ((>>>))
115 import Control.Concurrent
116 import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, forOf_, (%%~), (?~), mapped)
117 import Control.Monad.Error.Class (MonadError)
118 import Control.Monad.Reader
119 import Control.Monad.State
120 import Data.Aeson hiding ((.=))
121 import Data.Aeson.TH (deriveJSON)
122 import Data.Either(Either(Left))
123 -- import Data.Map (lookup)
124 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
125 import Data.Swagger hiding (version, patch)
126 import Data.Text (Text, isInfixOf, count)
127 import Data.Validity
128 import Formatting (hprint, int, (%))
129 import Formatting.Clock (timeSpecs)
130 import GHC.Generics (Generic)
131 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
132 -- import Gargantext.Database.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
133 import Gargantext.Database.Config (userMaster)
134 import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlyFast')
135 import Gargantext.Database.Schema.Ngrams (NgramsType)
136 import Gargantext.Database.Types.Node (NodeType(..))
137 import Gargantext.Database.Utils (fromField', HasConnection)
138 import Gargantext.Database.Node.Select
139 import Gargantext.Database.Ngrams
140 --import Gargantext.Database.Lists (listsWith)
141 import Gargantext.Database.Schema.Node (HasNodeError)
142 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
143 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
144 -- import Gargantext.Database.Schema.NodeNgram hiding (Action)
145 import Gargantext.Prelude
146 import Gargantext.Core.Types (TODO)
147 import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, HasInvalidError, assertValid)
148 import Servant hiding (Patch)
149 import System.Clock (getTime, TimeSpec, Clock(..))
150 import System.FileLock (FileLock)
151 import System.IO (stderr)
152 import Test.QuickCheck (elements)
153 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
154
155 ------------------------------------------------------------------------
156 --data FacetFormat = Table | Chart
157 data TabType = Docs | Trash | MoreFav | MoreTrash
158 | Terms | Sources | Authors | Institutes
159 | Contacts
160 deriving (Generic, Enum, Bounded, Show)
161
162 instance FromHttpApiData TabType
163 where
164 parseUrlPiece "Docs" = pure Docs
165 parseUrlPiece "Trash" = pure Trash
166 parseUrlPiece "MoreFav" = pure MoreFav
167 parseUrlPiece "MoreTrash" = pure MoreTrash
168
169 parseUrlPiece "Terms" = pure Terms
170 parseUrlPiece "Sources" = pure Sources
171 parseUrlPiece "Institutes" = pure Institutes
172 parseUrlPiece "Authors" = pure Authors
173
174 parseUrlPiece "Contacts" = pure Contacts
175
176 parseUrlPiece _ = Left "Unexpected value of TabType"
177
178 instance ToParamSchema TabType
179 instance ToJSON TabType
180 instance FromJSON TabType
181 instance ToSchema TabType
182 instance Arbitrary TabType
183 where
184 arbitrary = elements [minBound .. maxBound]
185
186 newtype MSet a = MSet (Map a ())
187 deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
188
189 instance ToJSON a => ToJSON (MSet a) where
190 toJSON (MSet m) = toJSON (Map.keys m)
191 toEncoding (MSet m) = toEncoding (Map.keys m)
192
193 mSetFromSet :: Set a -> MSet a
194 mSetFromSet = MSet . Map.fromSet (const ())
195
196 mSetFromList :: Ord a => [a] -> MSet a
197 mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
198
199 -- mSetToSet :: Ord a => MSet a -> Set a
200 -- mSetToSet (MSet a) = Set.fromList ( Map.keys a)
201 mSetToSet :: Ord a => MSet a -> Set a
202 mSetToSet = Set.fromList . mSetToList
203
204 mSetToList :: MSet a -> [a]
205 mSetToList (MSet a) = Map.keys a
206
207 instance Foldable MSet where
208 foldMap f (MSet m) = Map.foldMapWithKey (\k _ -> f k) m
209
210 instance (Ord a, FromJSON a) => FromJSON (MSet a) where
211 parseJSON = fmap mSetFromList . parseJSON
212
213 instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
214 -- TODO
215 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
216
217 ------------------------------------------------------------------------
218 type NgramsTerm = Text
219
220 data RootParent = RootParent
221 { _rp_root :: NgramsTerm
222 , _rp_parent :: NgramsTerm
223 }
224 deriving (Ord, Eq, Show, Generic)
225
226 deriveJSON (unPrefix "_rp_") ''RootParent
227 makeLenses ''RootParent
228
229 data NgramsRepoElement = NgramsRepoElement
230 { _nre_size :: Int
231 , _nre_list :: ListType
232 --, _nre_root_parent :: Maybe RootParent
233 , _nre_root :: Maybe NgramsTerm
234 , _nre_parent :: Maybe NgramsTerm
235 , _nre_children :: MSet NgramsTerm
236 }
237 deriving (Ord, Eq, Show, Generic)
238
239 deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
240 makeLenses ''NgramsRepoElement
241
242 data NgramsElement =
243 NgramsElement { _ne_ngrams :: NgramsTerm
244 , _ne_size :: Int
245 , _ne_list :: ListType
246 , _ne_occurrences :: Int
247 , _ne_root :: Maybe NgramsTerm
248 , _ne_parent :: Maybe NgramsTerm
249 , _ne_children :: MSet NgramsTerm
250 }
251 deriving (Ord, Eq, Show, Generic)
252
253 deriveJSON (unPrefix "_ne_") ''NgramsElement
254 makeLenses ''NgramsElement
255
256 mkNgramsElement :: NgramsTerm -> ListType -> Maybe RootParent -> MSet NgramsTerm -> NgramsElement
257 mkNgramsElement ngrams list rp children =
258 NgramsElement ngrams size list 1 (_rp_root <$> rp) (_rp_parent <$> rp) children
259 where
260 -- TODO review
261 size = 1 + count " " ngrams
262
263 newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement
264 newNgramsElement mayList ngrams = mkNgramsElement ngrams (fromMaybe GraphTerm mayList) Nothing mempty
265
266 instance ToSchema NgramsElement where
267 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
268 instance Arbitrary NgramsElement where
269 arbitrary = elements [newNgramsElement Nothing "sport"]
270
271 ngramsElementToRepo :: NgramsElement -> NgramsRepoElement
272 ngramsElementToRepo
273 (NgramsElement { _ne_size = s
274 , _ne_list = l
275 , _ne_root = r
276 , _ne_parent = p
277 , _ne_children = c
278 }) =
279 NgramsRepoElement
280 { _nre_size = s
281 , _nre_list = l
282 , _nre_parent = p
283 , _nre_root = r
284 , _nre_children = c
285 }
286
287 ngramsElementFromRepo :: NgramsTerm -> NgramsRepoElement -> NgramsElement
288 ngramsElementFromRepo
289 ngrams
290 (NgramsRepoElement
291 { _nre_size = s
292 , _nre_list = l
293 , _nre_parent = p
294 , _nre_root = r
295 , _nre_children = c
296 }) =
297 NgramsElement { _ne_size = s
298 , _ne_list = l
299 , _ne_root = r
300 , _ne_parent = p
301 , _ne_children = c
302 , _ne_ngrams = ngrams
303 , _ne_occurrences = panic $ "API.Ngrams._ne_occurrences"
304 {-
305 -- Here we could use 0 if we want to avoid any `panic`.
306 -- It will not happen using getTableNgrams if
307 -- getOccByNgramsOnly provides a count of occurrences for
308 -- all the ngrams given.
309 -}
310 }
311
312 ------------------------------------------------------------------------
313 newtype NgramsTable = NgramsTable [NgramsElement]
314 deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
315
316 type ListNgrams = NgramsTable
317
318 makePrisms ''NgramsTable
319
320 -- | Question: why these repetition of Type in this instance
321 -- may you document it please ?
322 instance Each NgramsTable NgramsTable NgramsElement NgramsElement where
323 each = _NgramsTable . each
324
325 -- TODO discuss
326 -- | TODO Check N and Weight
327 {-
328 toNgramsElement :: [NgramsTableData] -> [NgramsElement]
329 toNgramsElement ns = map toNgramsElement' ns
330 where
331 toNgramsElement' (NgramsTableData _ p t _ lt w) = NgramsElement t lt' (round w) p' c'
332 where
333 p' = case p of
334 Nothing -> Nothing
335 Just x -> lookup x mapParent
336 c' = maybe mempty identity $ lookup t mapChildren
337 lt' = maybe (panic "API.Ngrams: listypeId") identity lt
338
339 mapParent :: Map Int Text
340 mapParent = Map.fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
341
342 mapChildren :: Map Text (Set Text)
343 mapChildren = Map.mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
344 $ Map.fromListWith (<>)
345 $ map (first fromJust)
346 $ filter (isJust . fst)
347 $ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
348 -}
349
350 mockTable :: NgramsTable
351 mockTable = NgramsTable
352 [ mkNgramsElement "animal" GraphTerm Nothing (mSetFromList ["dog", "cat"])
353 , mkNgramsElement "cat" GraphTerm (rp "animal") mempty
354 , mkNgramsElement "cats" StopTerm Nothing mempty
355 , mkNgramsElement "dog" GraphTerm (rp "animal") (mSetFromList ["dogs"])
356 , mkNgramsElement "dogs" StopTerm (rp "dog") mempty
357 , mkNgramsElement "fox" GraphTerm Nothing mempty
358 , mkNgramsElement "object" CandidateTerm Nothing mempty
359 , mkNgramsElement "nothing" StopTerm Nothing mempty
360 , mkNgramsElement "organic" GraphTerm Nothing (mSetFromList ["flower"])
361 , mkNgramsElement "flower" GraphTerm (rp "organic") mempty
362 , mkNgramsElement "moon" CandidateTerm Nothing mempty
363 , mkNgramsElement "sky" StopTerm Nothing mempty
364 ]
365 where
366 rp n = Just $ RootParent n n
367
368 instance Arbitrary NgramsTable where
369 arbitrary = pure mockTable
370
371 instance ToSchema NgramsTable
372
373 ------------------------------------------------------------------------
374 type NgramsTableMap = Map NgramsTerm NgramsRepoElement
375
376 ------------------------------------------------------------------------
377 -- On the Client side:
378 --data Action = InGroup NgramsId NgramsId
379 -- | OutGroup NgramsId NgramsId
380 -- | SetListType NgramsId ListType
381
382 data PatchSet a = PatchSet
383 { _rem :: Set a
384 , _add :: Set a
385 }
386 deriving (Eq, Ord, Show, Generic)
387
388 makeLenses ''PatchSet
389 makePrisms ''PatchSet
390
391 instance ToJSON a => ToJSON (PatchSet a) where
392 toJSON = genericToJSON $ unPrefix "_"
393 toEncoding = genericToEncoding $ unPrefix "_"
394
395 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
396 parseJSON = genericParseJSON $ unPrefix "_"
397
398 {-
399 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
400 arbitrary = PatchSet <$> arbitrary <*> arbitrary
401
402 type instance Patched (PatchSet a) = Set a
403
404 type ConflictResolutionPatchSet a = SimpleConflictResolution' (Set a)
405 type instance ConflictResolution (PatchSet a) = ConflictResolutionPatchSet a
406
407 instance Ord a => Semigroup (PatchSet a) where
408 p <> q = PatchSet { _rem = (q ^. rem) `Set.difference` (p ^. add) <> p ^. rem
409 , _add = (q ^. add) `Set.difference` (p ^. rem) <> p ^. add
410 } -- TODO Review
411
412 instance Ord a => Monoid (PatchSet a) where
413 mempty = PatchSet mempty mempty
414
415 instance Ord a => Group (PatchSet a) where
416 invert (PatchSet r a) = PatchSet a r
417
418 instance Ord a => Composable (PatchSet a) where
419 composable _ _ = undefined
420
421 instance Ord a => Action (PatchSet a) (Set a) where
422 act p source = (source `Set.difference` (p ^. rem)) <> p ^. add
423
424 instance Applicable (PatchSet a) (Set a) where
425 applicable _ _ = mempty
426
427 instance Ord a => Validity (PatchSet a) where
428 validate p = check (Set.disjoint (p ^. rem) (p ^. add)) "_rem and _add should be dijoint"
429
430 instance Ord a => Transformable (PatchSet a) where
431 transformable = undefined
432
433 conflicts _p _q = undefined
434
435 transformWith conflict p q = undefined conflict p q
436
437 instance ToSchema a => ToSchema (PatchSet a)
438 -}
439
440 type AddRem = Replace (Maybe ())
441
442 remPatch, addPatch :: AddRem
443 remPatch = replace (Just ()) Nothing
444 addPatch = replace Nothing (Just ())
445
446 isRem :: Replace (Maybe ()) -> Bool
447 isRem = (== remPatch)
448
449 type PatchMap = PM.PatchMap
450
451 newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
452 deriving (Eq, Show, Generic, Validity, Semigroup, Monoid,
453 Transformable, Composable)
454
455 type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
456 type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
457
458 -- TODO this breaks module abstraction
459 makePrisms ''PM.PatchMap
460
461 makePrisms ''PatchMSet
462
463 _PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
464 _PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
465 where
466 f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
467 f = Map.partition isRem >>> both %~ Map.keysSet
468
469 g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
470 g (rems, adds) = Map.fromSet (const remPatch) rems
471 <> Map.fromSet (const addPatch) adds
472
473 instance Ord a => Action (PatchMSet a) (MSet a) where
474 act (PatchMSet p) (MSet m) = MSet $ act p m
475
476 instance Ord a => Applicable (PatchMSet a) (MSet a) where
477 applicable (PatchMSet p) (MSet m) = applicable p m
478
479 instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
480 toJSON = toJSON . view _PatchMSetIso
481 toEncoding = toEncoding . view _PatchMSetIso
482
483 instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
484 parseJSON = fmap (_PatchMSetIso #) . parseJSON
485
486 instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
487 arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
488
489 instance ToSchema a => ToSchema (PatchMSet a) where
490 -- TODO
491 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
492
493 type instance Patched (PatchMSet a) = MSet a
494
495 instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
496 arbitrary = uncurry replace <$> arbitrary
497 -- If they happen to be equal then the patch is Keep.
498
499 instance ToSchema a => ToSchema (Replace a) where
500 declareNamedSchema (_ :: Proxy (Replace a)) = do
501 -- TODO Keep constructor is not supported here.
502 aSchema <- declareSchemaRef (Proxy :: Proxy a)
503 return $ NamedSchema (Just "Replace") $ mempty
504 & type_ ?~ SwaggerObject
505 & properties .~
506 InsOrdHashMap.fromList
507 [ ("old", aSchema)
508 , ("new", aSchema)
509 ]
510 & required .~ [ "old", "new" ]
511
512 data NgramsPatch =
513 NgramsPatch { _patch_children :: PatchMSet NgramsTerm
514 , _patch_list :: Replace ListType -- TODO Map UserId ListType
515 }
516 deriving (Eq, Show, Generic)
517
518 deriveJSON (unPrefix "_") ''NgramsPatch
519 makeLenses ''NgramsPatch
520
521 instance ToSchema NgramsPatch where
522 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
523
524 instance Arbitrary NgramsPatch where
525 arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
526
527 type NgramsPatchIso = PairPatch (PatchMSet NgramsTerm) (Replace ListType)
528
529 _NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
530 _NgramsPatch = iso (\(NgramsPatch c l) -> c :*: l) (\(c :*: l) -> NgramsPatch c l)
531
532 instance Semigroup NgramsPatch where
533 p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
534
535 instance Monoid NgramsPatch where
536 mempty = _NgramsPatch # mempty
537
538 instance Validity NgramsPatch where
539 validate p = p ^. _NgramsPatch . to validate
540
541 instance Transformable NgramsPatch where
542 transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
543
544 conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
545
546 transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
547 where
548 (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
549
550 type ConflictResolutionNgramsPatch =
551 ( ConflictResolutionPatchMSet NgramsTerm
552 , ConflictResolutionReplace ListType
553 )
554 type instance ConflictResolution NgramsPatch =
555 ConflictResolutionNgramsPatch
556
557 type PatchedNgramsPatch = (Set NgramsTerm, ListType)
558 -- ~ Patched NgramsPatchIso
559 type instance Patched NgramsPatch = PatchedNgramsPatch
560
561 instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
562 applicable p Nothing = check (p == mempty) "NgramsPatch should be empty here"
563 applicable p (Just nre) =
564 applicable (p ^. patch_children) (nre ^. nre_children) <>
565 applicable (p ^. patch_list) (nre ^. nre_list)
566
567 instance Action NgramsPatch NgramsRepoElement where
568 act p = (nre_children %~ act (p ^. patch_children))
569 . (nre_list %~ act (p ^. patch_list))
570
571 instance Action NgramsPatch (Maybe NgramsRepoElement) where
572 act = fmap . act
573
574 newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
575 deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
576
577 instance FromField NgramsTablePatch
578 where
579 fromField = fromField'
580
581 instance FromField (PatchMap NgramsType (PatchMap NodeId NgramsTablePatch))
582 where
583 fromField = fromField'
584
585 --instance (Ord k, Action pv (Maybe v)) => Action (PatchMap k pv) (Map k v) where
586 --
587 type instance ConflictResolution NgramsTablePatch =
588 NgramsTerm -> ConflictResolutionNgramsPatch
589
590 type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
591 -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
592 type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
593
594 makePrisms ''NgramsTablePatch
595 instance ToSchema (PatchMap NgramsTerm NgramsPatch)
596 instance ToSchema NgramsTablePatch
597
598 instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
599 applicable p = applicable (p ^. _NgramsTablePatch)
600
601 instance Action NgramsTablePatch (Maybe NgramsTableMap) where
602 act p =
603 fmap (execState (reParentNgramsTablePatch p)) .
604 act (p ^. _NgramsTablePatch)
605
606 instance Arbitrary NgramsTablePatch where
607 arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
608
609 -- Should it be less than an Lens' to preserve PatchMap's abstraction.
610 -- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
611 -- ntp_ngrams_patches = _NgramsTablePatch . undefined
612
613 type ReParent a = forall m. MonadState NgramsTableMap m => a -> m ()
614
615 reRootChildren :: NgramsTerm -> ReParent NgramsTerm
616 reRootChildren root ngram = do
617 nre <- use $ at ngram
618 forOf_ (_Just . nre_children . folded) nre $ \child -> do
619 at child . _Just . nre_root ?= root
620 reRootChildren root child
621
622 reParent :: Maybe RootParent -> ReParent NgramsTerm
623 reParent rp child = do
624 at child . _Just %= ( (nre_parent .~ (_rp_parent <$> rp))
625 . (nre_root .~ (_rp_root <$> rp))
626 )
627 reRootChildren (fromMaybe child (rp ^? _Just . rp_root)) child
628
629 reParentAddRem :: RootParent -> NgramsTerm -> ReParent AddRem
630 reParentAddRem rp child p =
631 reParent (if isRem p then Nothing else Just rp) child
632
633 reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
634 reParentNgramsPatch parent ngramsPatch = do
635 root_of_parent <- use (at parent . _Just . nre_root)
636 let
637 root = fromMaybe parent root_of_parent
638 rp = RootParent { _rp_root = root, _rp_parent = parent }
639 itraverse_ (reParentAddRem rp) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap)
640 -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
641
642 reParentNgramsTablePatch :: ReParent NgramsTablePatch
643 reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
644 -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
645
646 ------------------------------------------------------------------------
647 ------------------------------------------------------------------------
648 type Version = Int
649
650 data Versioned a = Versioned
651 { _v_version :: Version
652 , _v_data :: a
653 }
654 deriving (Generic, Show)
655 deriveJSON (unPrefix "_v_") ''Versioned
656 makeLenses ''Versioned
657 instance ToSchema a => ToSchema (Versioned a) where
658 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_v_")
659 instance Arbitrary a => Arbitrary (Versioned a) where
660 arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
661
662 {-
663 -- TODO sequencs of modifications (Patchs)
664 type NgramsIdPatch = Patch NgramsId NgramsPatch
665
666 ngramsPatch :: Int -> NgramsPatch
667 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopTerm)]) (Set.fromList [n]) Set.empty
668
669 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
670 toEdit n p = Edit n p
671 ngramsIdPatch :: Patch NgramsId NgramsPatch
672 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
673 , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
674 , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
675 ]
676
677 -- applyPatchBack :: Patch -> IO Patch
678 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
679 -}
680 ------------------------------------------------------------------------
681 ------------------------------------------------------------------------
682 ------------------------------------------------------------------------
683
684 {-
685 -- TODO: Replace.old is ignored which means that if the current list
686 -- `GraphTerm` and that the patch is `Replace CandidateTerm StopTerm` then
687 -- the list is going to be `StopTerm` while it should keep `GraphTerm`.
688 -- However this should not happen in non conflicting situations.
689 mkListsUpdate :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)]
690 mkListsUpdate nt patches =
691 [ (ngramsTypeId nt, ng, listTypeId lt)
692 | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
693 , lt <- patch ^.. patch_list . new
694 ]
695
696 mkChildrenGroups :: (PatchSet NgramsTerm -> Set NgramsTerm)
697 -> NgramsType
698 -> NgramsTablePatch
699 -> [(NgramsTypeId, NgramsParent, NgramsChild)]
700 mkChildrenGroups addOrRem nt patches =
701 [ (ngramsTypeId nt, parent, child)
702 | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
703 , child <- patch ^.. patch_children . to addOrRem . folded
704 ]
705 -}
706
707 ngramsTypeFromTabType :: TabType -> NgramsType
708 ngramsTypeFromTabType tabType =
709 let lieu = "Garg.API.Ngrams: " :: Text in
710 case tabType of
711 Sources -> Ngrams.Sources
712 Authors -> Ngrams.Authors
713 Institutes -> Ngrams.Institutes
714 Terms -> Ngrams.NgramsTerms
715 _ -> panic $ lieu <> "No Ngrams for this tab"
716 -- TODO: This `panic` would disapear with custom NgramsType.
717
718 ------------------------------------------------------------------------
719 data Repo s p = Repo
720 { _r_version :: Version
721 , _r_state :: s
722 , _r_history :: [p]
723 -- first patch in the list is the most recent
724 }
725 deriving (Generic)
726
727 instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
728 parseJSON = genericParseJSON $ unPrefix "_r_"
729
730 instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
731 toJSON = genericToJSON $ unPrefix "_r_"
732 toEncoding = genericToEncoding $ unPrefix "_r_"
733
734 makeLenses ''Repo
735
736 initRepo :: Monoid s => Repo s p
737 initRepo = Repo 1 mempty []
738
739 type NgramsRepo = Repo NgramsState NgramsStatePatch
740 type NgramsState = Map NgramsType (Map NodeId NgramsTableMap)
741 type NgramsStatePatch = PatchMap NgramsType (PatchMap NodeId NgramsTablePatch)
742
743 initMockRepo :: NgramsRepo
744 initMockRepo = Repo 1 s []
745 where
746 s = Map.singleton Ngrams.NgramsTerms
747 $ Map.singleton 47254
748 $ Map.fromList
749 [ (n ^. ne_ngrams, ngramsElementToRepo n) | n <- mockTable ^. _NgramsTable ]
750
751 data RepoEnv = RepoEnv
752 { _renv_var :: !(MVar NgramsRepo)
753 , _renv_saver :: !(IO ())
754 , _renv_lock :: !FileLock
755 }
756 deriving (Generic)
757
758 makeLenses ''RepoEnv
759
760 class HasRepoVar env where
761 repoVar :: Getter env (MVar NgramsRepo)
762
763 instance HasRepoVar (MVar NgramsRepo) where
764 repoVar = identity
765
766 class HasRepoSaver env where
767 repoSaver :: Getter env (IO ())
768
769 class (HasRepoVar env, HasRepoSaver env) => HasRepo env where
770 repoEnv :: Getter env RepoEnv
771
772 instance HasRepo RepoEnv where
773 repoEnv = identity
774
775 instance HasRepoVar RepoEnv where
776 repoVar = renv_var
777
778 instance HasRepoSaver RepoEnv where
779 repoSaver = renv_saver
780
781 type RepoCmdM env err m =
782 ( MonadReader env m
783 , MonadError err m
784 , MonadIO m
785 , HasRepo env
786 )
787 ------------------------------------------------------------------------
788
789 saveRepo :: ( MonadReader env m, MonadIO m, HasRepoSaver env )
790 => m ()
791 saveRepo = liftIO =<< view repoSaver
792
793 listTypeConflictResolution :: ListType -> ListType -> ListType
794 listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
795
796 ngramsStatePatchConflictResolution
797 :: NgramsType -> NodeId -> NgramsTerm
798 -> ConflictResolutionNgramsPatch
799 ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
800 = (const ours, ours)
801 -- undefined {- TODO think this through -}, listTypeConflictResolution)
802
803 -- Current state:
804 -- Insertions are not considered as patches,
805 -- they do not extend history,
806 -- they do not bump version.
807 insertNewOnly :: a -> Maybe b -> a
808 insertNewOnly m = maybe m (const $ error "insertNewOnly: impossible")
809 -- TODO error handling
810
811 something :: Monoid a => Maybe a -> a
812 something Nothing = mempty
813 something (Just a) = a
814
815 {- unused
816 -- TODO refactor with putListNgrams
817 copyListNgrams :: RepoCmdM env err m
818 => NodeId -> NodeId -> NgramsType
819 -> m ()
820 copyListNgrams srcListId dstListId ngramsType = do
821 var <- view repoVar
822 liftIO $ modifyMVar_ var $
823 pure . (r_state . at ngramsType %~ (Just . f . something))
824 saveRepo
825 where
826 f :: Map NodeId NgramsTableMap -> Map NodeId NgramsTableMap
827 f m = m & at dstListId %~ insertNewOnly (m ^. at srcListId)
828
829 -- TODO refactor with putListNgrams
830 -- The list must be non-empty!
831 -- The added ngrams must be non-existent!
832 addListNgrams :: RepoCmdM env err m
833 => NodeId -> NgramsType
834 -> [NgramsElement] -> m ()
835 addListNgrams listId ngramsType nes = do
836 var <- view repoVar
837 liftIO $ modifyMVar_ var $
838 pure . (r_state . at ngramsType . _Just . at listId . _Just <>~ m)
839 saveRepo
840 where
841 m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
842 -}
843
844 -- If the given list of ngrams elements contains ngrams already in
845 -- the repo, they will be ignored.
846 putListNgrams :: RepoCmdM env err m
847 => NodeId -> NgramsType
848 -> [NgramsElement] -> m ()
849 putListNgrams _ _ [] = pure ()
850 putListNgrams listId ngramsType nes = do
851 -- printDebug "putListNgrams" (length nes)
852 var <- view repoVar
853 liftIO $ modifyMVar_ var $
854 pure . (r_state . at ngramsType %~ (Just . (at listId %~ (Just . (<> m) . something)) . something))
855 saveRepo
856 where
857 m = Map.fromList $ (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) <$> nes
858
859 -- TODO-ACCESS check
860 tableNgramsPost :: RepoCmdM env err m => TabType -> NodeId -> Maybe ListType -> [NgramsTerm] -> m ()
861 tableNgramsPost tabType listId mayList =
862 putListNgrams listId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
863
864 currentVersion :: RepoCmdM env err m => m Version
865 currentVersion = do
866 var <- view repoVar
867 r <- liftIO $ readMVar var
868 pure $ r ^. r_version
869
870 tableNgramsPull :: RepoCmdM env err m
871 => ListId -> NgramsType
872 -> Version
873 -> m (Versioned NgramsTablePatch)
874 tableNgramsPull listId ngramsType p_version = do
875 var <- view repoVar
876 r <- liftIO $ readMVar var
877
878 let
879 q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
880 q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
881
882 pure (Versioned (r ^. r_version) q_table)
883
884 -- Apply the given patch to the DB and returns the patch to be applied on the
885 -- client.
886 -- TODO-ACCESS check
887 tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
888 => TabType -> ListId
889 -> Versioned NgramsTablePatch
890 -> m (Versioned NgramsTablePatch)
891 tableNgramsPut tabType listId (Versioned p_version p_table)
892 | p_table == mempty = do
893 let ngramsType = ngramsTypeFromTabType tabType
894 tableNgramsPull listId ngramsType p_version
895
896 | otherwise = do
897 let ngramsType = ngramsTypeFromTabType tabType
898 (p0, p0_validity) = PM.singleton listId p_table
899 (p, p_validity) = PM.singleton ngramsType p0
900
901 assertValid p0_validity
902 assertValid p_validity
903
904 var <- view repoVar
905 vq' <- liftIO $ modifyMVar var $ \r -> do
906 let
907 q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
908 (p', q') = transformWith ngramsStatePatchConflictResolution p q
909 r' = r & r_version +~ 1
910 & r_state %~ act p'
911 & r_history %~ (p' :)
912 q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
913 {-
914 -- Ideally we would like to check these properties. However:
915 -- * They should be checked only to debug the code. The client data
916 -- should be able to trigger these.
917 -- * What kind of error should they throw (we are in IO here)?
918 -- * Should we keep modifyMVar?
919 -- * Should we throw the validation in an Exception, catch it around
920 -- modifyMVar and throw it back as an Error?
921 assertValid $ transformable p q
922 assertValid $ applicable p' (r ^. r_state)
923 -}
924 pure (r', Versioned (r' ^. r_version) q'_table)
925
926 saveRepo
927 pure vq'
928
929 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
930 mergeNgramsElement _neOld neNew = neNew
931 {-
932 { _ne_list :: ListType
933 If we merge the parents/children we can potentially create cycles!
934 , _ne_parent :: Maybe NgramsTerm
935 , _ne_children :: MSet NgramsTerm
936 }
937 -}
938
939 getNgramsTableMap :: RepoCmdM env err m
940 => NodeId -> NgramsType -> m (Versioned NgramsTableMap)
941 getNgramsTableMap nodeId ngramsType = do
942 v <- view repoVar
943 repo <- liftIO $ readMVar v
944 pure $ Versioned (repo ^. r_version)
945 (repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
946
947 type MinSize = Int
948 type MaxSize = Int
949
950 -- | TODO Errors management
951 -- TODO: polymorphic for Annuaire or Corpus or ...
952 -- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
953 -- TODO: should take only one ListId
954
955 getTime' :: MonadIO m => m TimeSpec
956 getTime' = liftIO $ getTime ProcessCPUTime
957
958
959 getTableNgrams :: forall env err m.
960 (RepoCmdM env err m, HasNodeError err, HasConnection env)
961 => NodeType -> NodeId -> TabType
962 -> ListId -> Limit -> Maybe Offset
963 -> Maybe ListType
964 -> Maybe MinSize -> Maybe MaxSize
965 -> Maybe OrderBy
966 -> (NgramsTerm -> Bool)
967 -> m (Versioned NgramsTable)
968 getTableNgrams _nType nId tabType listId limit_ offset
969 listType minSize maxSize orderBy searchQuery = do
970
971 t0 <- getTime'
972 -- lIds <- selectNodesWithUsername NodeList userMaster
973 let
974 ngramsType = ngramsTypeFromTabType tabType
975 offset' = maybe 0 identity offset
976 listType' = maybe (const True) (==) listType
977 minSize' = maybe (const True) (<=) minSize
978 maxSize' = maybe (const True) (>=) maxSize
979
980 selected_node n = minSize' s
981 && maxSize' s
982 && searchQuery (n ^. ne_ngrams)
983 && listType' (n ^. ne_list)
984 where
985 s = n ^. ne_size
986
987 selected_inner roots n = maybe False (`Set.member` roots) (n ^. ne_root)
988
989 ---------------------------------------
990 sortOnOrder Nothing = identity
991 sortOnOrder (Just TermAsc) = List.sortOn $ view ne_ngrams
992 sortOnOrder (Just TermDesc) = List.sortOn $ Down . view ne_ngrams
993 sortOnOrder (Just ScoreAsc) = List.sortOn $ view ne_occurrences
994 sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view ne_occurrences
995
996 ---------------------------------------
997 selectAndPaginate :: Map NgramsTerm NgramsElement -> [NgramsElement]
998 selectAndPaginate tableMap = roots <> inners
999 where
1000 list = tableMap ^.. each
1001 rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root") (tableMap ^. at r))
1002 (ne ^. ne_root)
1003 selected_nodes = list & take limit_
1004 . drop offset'
1005 . filter selected_node
1006 . sortOnOrder orderBy
1007 roots = rootOf <$> selected_nodes
1008 rootsSet = Set.fromList (_ne_ngrams <$> roots)
1009 inners = list & filter (selected_inner rootsSet)
1010
1011 ---------------------------------------
1012 setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
1013 setScores False table = pure table
1014 setScores True table = do
1015 let ngrams_terms = (table ^.. each . ne_ngrams)
1016 t1 <- getTime'
1017 occurrences <- getOccByNgramsOnlyFast' nId
1018 listId
1019 ngramsType
1020 ngrams_terms
1021 t2 <- getTime'
1022 liftIO $ hprint stderr
1023 ("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
1024 (length ngrams_terms) t1 t2
1025 {-
1026 occurrences <- getOccByNgramsOnlySlow nType nId
1027 (lIds <> [listId])
1028 ngramsType
1029 ngrams_terms
1030 -}
1031 let
1032 setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
1033
1034 pure $ table & each %~ setOcc
1035 ---------------------------------------
1036
1037 -- lists <- catMaybes <$> listsWith userMaster
1038 -- trace (show lists) $
1039 -- getNgramsTableMap ({-lists <>-} listIds) ngramsType
1040
1041 let scoresNeeded = needsScores orderBy
1042 tableMap1 <- getNgramsTableMap listId ngramsType
1043 t1 <- getTime'
1044 tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
1045 . Map.mapWithKey ngramsElementFromRepo
1046 t2 <- getTime'
1047 tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
1048 . setScores (not scoresNeeded)
1049 . selectAndPaginate
1050 t3 <- getTime'
1051 liftIO $ hprint stderr
1052 ("getTableNgrams total=" % timeSpecs
1053 % " map1=" % timeSpecs
1054 % " map2=" % timeSpecs
1055 % " map3=" % timeSpecs
1056 % " sql=" % (if scoresNeeded then "map2" else "map3")
1057 % "\n"
1058 ) t0 t3 t0 t1 t1 t2 t2 t3
1059 pure tableMap3
1060
1061
1062 -- APIs
1063
1064 -- TODO: find a better place for the code above, All APIs stay here
1065 type QueryParamR = QueryParam' '[Required, Strict]
1066
1067
1068 data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
1069 deriving (Generic, Enum, Bounded, Read, Show)
1070
1071 instance FromHttpApiData OrderBy
1072 where
1073 parseUrlPiece "TermAsc" = pure TermAsc
1074 parseUrlPiece "TermDesc" = pure TermDesc
1075 parseUrlPiece "ScoreAsc" = pure ScoreAsc
1076 parseUrlPiece "ScoreDesc" = pure ScoreDesc
1077 parseUrlPiece _ = Left "Unexpected value of OrderBy"
1078
1079 instance ToParamSchema OrderBy
1080 instance FromJSON OrderBy
1081 instance ToJSON OrderBy
1082 instance ToSchema OrderBy
1083 instance Arbitrary OrderBy
1084 where
1085 arbitrary = elements [minBound..maxBound]
1086
1087 needsScores :: Maybe OrderBy -> Bool
1088 needsScores (Just ScoreAsc) = True
1089 needsScores (Just ScoreDesc) = True
1090 needsScores _ = False
1091
1092 type TableNgramsApiGet = Summary " Table Ngrams API Get"
1093 :> QueryParamR "ngramsType" TabType
1094 :> QueryParamR "list" ListId
1095 :> QueryParamR "limit" Limit
1096 :> QueryParam "offset" Offset
1097 :> QueryParam "listType" ListType
1098 :> QueryParam "minTermSize" MinSize
1099 :> QueryParam "maxTermSize" MaxSize
1100 :> QueryParam "orderBy" OrderBy
1101 :> QueryParam "search" Text
1102 :> Get '[JSON] (Versioned NgramsTable)
1103
1104 type TableNgramsApiPut = Summary " Table Ngrams API Change"
1105 :> QueryParamR "ngramsType" TabType
1106 :> QueryParamR "list" ListId
1107 :> ReqBody '[JSON] (Versioned NgramsTablePatch)
1108 :> Put '[JSON] (Versioned NgramsTablePatch)
1109
1110 type TableNgramsApiPost = Summary " Table Ngrams API Adds new ngrams"
1111 :> QueryParamR "ngramsType" TabType
1112 :> QueryParamR "list" ListId
1113 :> QueryParam "listType" ListType
1114 :> ReqBody '[JSON] [NgramsTerm]
1115 :> Post '[JSON] ()
1116
1117 type TableNgramsApi = TableNgramsApiGet
1118 :<|> TableNgramsApiPut
1119 :<|> TableNgramsApiPost
1120
1121 getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
1122 => NodeId -> TabType
1123 -> ListId -> Limit -> Maybe Offset
1124 -> Maybe ListType
1125 -> Maybe MinSize -> Maybe MaxSize
1126 -> Maybe OrderBy
1127 -> Maybe Text -- full text search
1128 -> m (Versioned NgramsTable)
1129 getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
1130 getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
1131 where
1132 searchQuery = maybe (const True) isInfixOf mt
1133
1134 -- | Text search is deactivated for now for ngrams by doc only
1135 getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
1136 => DocId -> TabType
1137 -> ListId -> Limit -> Maybe Offset
1138 -> Maybe ListType
1139 -> Maybe MinSize -> Maybe MaxSize
1140 -> Maybe OrderBy
1141 -> Maybe Text -- full text search
1142 -> m (Versioned NgramsTable)
1143 getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do
1144 ns <- selectNodesWithUsername NodeList userMaster
1145 let ngramsType = ngramsTypeFromTabType tabType
1146 ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
1147 let searchQuery = flip S.member (S.fromList ngs)
1148 getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
1149
1150
1151
1152 apiNgramsTableCorpus :: ( RepoCmdM env err m
1153 , HasNodeError err
1154 , HasInvalidError err
1155 , HasConnection env
1156 )
1157 => NodeId -> ServerT TableNgramsApi m
1158 apiNgramsTableCorpus cId = getTableNgramsCorpus cId
1159 :<|> tableNgramsPut
1160 :<|> tableNgramsPost
1161
1162
1163 apiNgramsTableDoc :: ( RepoCmdM env err m
1164 , HasNodeError err
1165 , HasInvalidError err
1166 , HasConnection env
1167 )
1168 => DocId -> ServerT TableNgramsApi m
1169 apiNgramsTableDoc dId = getTableNgramsDoc dId
1170 :<|> tableNgramsPut
1171 :<|> tableNgramsPost
1172 -- > add new ngrams in database (TODO AD)
1173 -- > index all the corpus accordingly (TODO AD)
1174
1175 listNgramsChangedSince :: RepoCmdM env err m => ListId -> NgramsType -> Version -> m (Versioned Bool)
1176 listNgramsChangedSince listId ngramsType version
1177 | version < 0 =
1178 Versioned <$> currentVersion <*> pure True
1179 | otherwise =
1180 tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)