src/Gargantext/API/Ngrams.hs

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