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