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