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