src/Gargantext/API/Ngrams.hs

   1 {-|
   2 Module      : Gargantext.API.Ngrams
   3 Description : Server API
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Ngrams API
  11
  12 -- | TODO
  13 get ngrams filtered by NgramsType
  14 add get
  15
  16 -}
  17
  18 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
  19
  20 {-# LANGUAGE ConstraintKinds   #-}
  21 {-# LANGUAGE ScopedTypeVariables #-}
  22 {-# LANGUAGE TypeOperators     #-}
  23 {-# LANGUAGE TypeFamilies      #-}
  24
  25 {-# LANGUAGE IncoherentInstances #-}
  26 module Gargantext.API.Ngrams
  27   ( TableNgramsApi
  28   , TableNgramsApiGet
  29   , TableNgramsApiPut
  30
  31   , getTableNgrams
  32   , setListNgrams
  33   --, rmListNgrams TODO fix before exporting
  34   , apiNgramsTableCorpus
  35   , apiNgramsTableDoc
  36
  37   , NgramsTablePatch
  38   , NgramsTableMap
  39
  40   , NgramsTerm(..)
  41
  42   , NgramsElement(..)
  43   , mkNgramsElement
  44
  45   , RootParent(..)
  46
  47   , MSet
  48   , mSetFromList
  49   , mSetToList
  50
  51   , Repo(..)
  52   , r_version
  53   , r_state
  54   , r_history
  55   , NgramsRepoElement(..)
  56   , saveNodeStory
  57   , initRepo
  58
  59   , TabType(..)
  60
  61   , QueryParamR
  62   , TODO
  63
  64   -- Internals
  65   , getNgramsTableMap
  66   , dumpJsonTableMap
  67   , tableNgramsPull
  68   , tableNgramsPut
  69
  70   , Version
  71   , Versioned(..)
  72   , VersionedWithCount(..)
  73   , currentVersion
  74   , listNgramsChangedSince
  75   , MinSize, MaxSize, OrderBy, NgramsTable
  76   , UpdateTableNgramsCharts
  77   )
  78   where
  79
  80 import Control.Concurrent
  81 import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), sumOf, at, _Just, Each(..), (%%~), mapped, ifolded, withIndex)
  82 import Control.Monad.Reader
  83 import Data.Aeson hiding ((.=))
  84 import Data.Either (Either(..))
  85 import Data.Foldable
  86 import Data.Map.Strict (Map)
  87 import Data.Maybe (fromMaybe)
  88 import Data.Monoid
  89 import Data.Ord (Down(..))
  90 import Data.Patch.Class (Action(act), Transformable(..), ours)
  91 import Data.Swagger hiding (version, patch)
  92 import Data.Text (Text, isInfixOf, unpack, pack)
  93 import Data.Text.Lazy.IO as DTL
  94 import Formatting (hprint, int, (%))
  95 import GHC.Generics (Generic)
  96 import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
  97 import Gargantext.API.Admin.Types (HasSettings)
  98 import Gargantext.API.Job
  99 import Gargantext.API.Ngrams.Types
 100 import Gargantext.API.Prelude
 101 import Gargantext.Core.NodeStory
 102 import Gargantext.Core.Mail.Types (HasMail)
 103 import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, TODO, assertValid, HasInvalidError)
 104 import Gargantext.API.Ngrams.Tools
 105 import Gargantext.Database.Action.Flow.Types
 106 import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast')
 107 import Gargantext.Database.Admin.Config (userMaster)
 108 import Gargantext.Database.Admin.Types.Node (NodeType(..))
 109 import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
 110 import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngramsType, ngrams_terms)
 111 import Gargantext.Database.Query.Table.Node (getNode)
 112 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
 113 import Gargantext.Database.Query.Table.Node.Select
 114 import Gargantext.Database.Schema.Node (node_id, node_parent_id, node_user_id)
 115 import Gargantext.Prelude hiding (log)
 116 import Gargantext.Prelude.Clock (hasTime, getTime)
 117 import Prelude (error)
 118 import Servant hiding (Patch)
 119 import Servant.Job.Async (JobFunction(..), serveJobsAPI)
 120 import System.IO (stderr)
 121 import Test.QuickCheck (elements)
 122 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 123 import qualified Data.Aeson.Text as DAT
 124 import qualified Data.List as List
 125 import qualified Data.Map.Strict as Map
 126 import qualified Data.Map.Strict.Patch as PM
 127 import qualified Data.Set as S
 128 import qualified Data.Set as Set
 129 import qualified Gargantext.API.Metrics as Metrics
 130 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
 131
 132 {-
 133 -- TODO sequences of modifications (Patchs)
 134 type NgramsIdPatch = Patch NgramsId NgramsPatch
 135
 136 ngramsPatch :: Int -> NgramsPatch
 137 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopTerm)]) (Set.fromList [n]) Set.empty
 138
 139 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 140 toEdit n p = Edit n p
 141 ngramsIdPatch :: Patch NgramsId NgramsPatch
 142 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 143                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 144                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 145                                        ]
 146
 147 -- applyPatchBack :: Patch -> IO Patch
 148 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 149 -}
 150 ------------------------------------------------------------------------
 151 ------------------------------------------------------------------------
 152 ------------------------------------------------------------------------
 153
 154 {-
 155 -- TODO: Replace.old is ignored which means that if the current list
 156 -- `MapTerm` and that the patch is `Replace CandidateTerm StopTerm` then
 157 -- the list is going to be `StopTerm` while it should keep `MapTerm`.
 158 -- However this should not happen in non conflicting situations.
 159 mkListsUpdate :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)]
 160 mkListsUpdate nt patches =
 161   [ (ngramsTypeId nt, ng, listTypeId lt)
 162   | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 163   , lt <- patch ^.. patch_list . new
 164   ]
 165
 166 mkChildrenGroups :: (PatchSet NgramsTerm -> Set NgramsTerm)
 167                  -> NgramsType
 168                  -> NgramsTablePatch
 169                  -> [(NgramsTypeId, NgramsParent, NgramsChild)]
 170 mkChildrenGroups addOrRem nt patches =
 171   [ (ngramsTypeId nt, parent, child)
 172   | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 173   , child <- patch ^.. patch_children . to addOrRem . folded
 174   ]
 175 -}
 176
 177 ------------------------------------------------------------------------
 178
 179 saveNodeStory :: ( MonadReader env m, MonadBase IO m, HasNodeStorySaver env )
 180          => m ()
 181 saveNodeStory = liftBase =<< view hasNodeStorySaver
 182
 183
 184 listTypeConflictResolution :: ListType -> ListType -> ListType
 185 listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
 186
 187
 188 ngramsStatePatchConflictResolution
 189   :: TableNgrams.NgramsType
 190   -> NgramsTerm
 191   -> ConflictResolutionNgramsPatch
 192 ngramsStatePatchConflictResolution _ngramsType _ngramsTerm
 193   = (ours, (const ours, ours), (False, False))
 194                              -- (False, False) mean here that Mod has always priority.
 195                              -- (True, False) <- would mean priority to the left (same as ours).
 196   -- undefined {- TODO think this through -}, listTypeConflictResolution)
 197
 198
 199
 200
 201 -- Current state:
 202 --   Insertions are not considered as patches,
 203 --   they do not extend history,
 204 --   they do not bump version.
 205 insertNewOnly :: a -> Maybe b -> a
 206 insertNewOnly m = maybe m (const $ error "insertNewOnly: impossible")
 207   -- TODO error handling
 208
 209 {- unused
 210 -- TODO refactor with putListNgrams
 211 copyListNgrams :: RepoCmdM env err m
 212                => NodeId -> NodeId -> NgramsType
 213                -> m ()
 214 copyListNgrams srcListId dstListId ngramsType = do
 215   var <- view repoVar
 216   liftBase $ modifyMVar_ var $
 217     pure . (r_state . at ngramsType %~ (Just . f . something))
 218   saveNodeStory
 219   where
 220     f :: Map NodeId NgramsTableMap -> Map NodeId NgramsTableMap
 221     f m = m & at dstListId %~ insertNewOnly (m ^. at srcListId)
 222
 223 -- TODO refactor with putListNgrams
 224 -- The list must be non-empty!
 225 -- The added ngrams must be non-existent!
 226 addListNgrams :: RepoCmdM env err m
 227               => NodeId -> NgramsType
 228               -> [NgramsElement] -> m ()
 229 addListNgrams listId ngramsType nes = do
 230   var <- view repoVar
 231   liftBase $ modifyMVar_ var $
 232     pure . (r_state . at ngramsType . _Just . at listId . _Just <>~ m)
 233   saveNodeStory
 234   where
 235     m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
 236 -}
 237
 238 -- | TODO: incr the Version number
 239 -- && should use patch
 240 -- UNSAFE
 241
 242 setListNgrams ::  HasNodeStory env err m
 243               => NodeId
 244               -> TableNgrams.NgramsType
 245               -> Map NgramsTerm NgramsRepoElement
 246               -> m ()
 247 setListNgrams listId ngramsType ns = do
 248   -- printDebug "[setListNgrams]" (listId, ngramsType)
 249   getter <- view hasNodeStory
 250   var <- liftBase $ (getter ^. nse_getter) [listId]
 251   liftBase $ modifyMVar_ var $
 252     pure . ( unNodeStory
 253            . at listId . _Just
 254             . a_state
 255               . at ngramsType
 256               .~ Just ns
 257            )
 258   saveNodeStory
 259
 260
 261 currentVersion :: HasNodeStory env err m
 262                => ListId -> m Version
 263 currentVersion listId = do
 264   nls <- getRepo [listId]
 265   pure $ nls ^. unNodeStory . at listId . _Just . a_version
 266
 267
 268 newNgramsFromNgramsStatePatch :: NgramsStatePatch' -> [Ngrams]
 269 newNgramsFromNgramsStatePatch p =
 270   [ text2ngrams (unNgramsTerm n)
 271   | (n,np) <- p ^.. _PatchMap
 272                 -- . each . _PatchMap
 273                 . each . _NgramsTablePatch
 274                 . _PatchMap . ifolded . withIndex
 275   , _ <- np ^.. patch_new . _Just
 276   ]
 277
 278
 279
 280
 281 commitStatePatch :: (HasNodeStory env err m, HasMail env)
 282                  => ListId
 283                  ->    Versioned NgramsStatePatch'
 284                  -> m (Versioned NgramsStatePatch')
 285 commitStatePatch listId (Versioned p_version p) = do
 286   -- printDebug "[commitStatePatch]" listId
 287   var <- getNodeStoryVar [listId]
 288   vq' <- liftBase $ modifyMVar var $ \ns -> do
 289     let
 290       a = ns ^. unNodeStory . at listId . _Just
 291       q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
 292       (p', q') = transformWith ngramsStatePatchConflictResolution p q
 293       a' = a & a_version +~ 1
 294              & a_state   %~ act p'
 295              & a_history %~ (p' :)
 296
 297     {-
 298     -- Ideally we would like to check these properties. However:
 299     -- * They should be checked only to debug the code. The client data
 300     --   should be able to trigger these.
 301     -- * What kind of error should they throw (we are in IO here)?
 302     -- * Should we keep modifyMVar?
 303     -- * Should we throw the validation in an Exception, catch it around
 304     --   modifyMVar and throw it back as an Error?
 305     assertValid $ transformable p q
 306     assertValid $ applicable p' (r ^. r_state)
 307     -}
 308     printDebug "[commitStatePatch] a version" (a ^. a_version)
 309     printDebug "[commitStatePatch] a' version" (a' ^. a_version)
 310     pure ( ns & unNodeStory . at listId .~ (Just a')
 311          , Versioned (a' ^. a_version) q'
 312          )
 313   saveNodeStory
 314   -- Save new ngrams
 315   _ <- insertNgrams (newNgramsFromNgramsStatePatch p)
 316
 317   pure vq'
 318
 319
 320
 321 -- This is a special case of tableNgramsPut where the input patch is empty.
 322 tableNgramsPull :: HasNodeStory env err m
 323                 => ListId
 324                 -> TableNgrams.NgramsType
 325                 -> Version
 326                 -> m (Versioned NgramsTablePatch)
 327 tableNgramsPull listId ngramsType p_version = do
 328   printDebug "[tableNgramsPull]" (listId, ngramsType)
 329   var <- getNodeStoryVar [listId]
 330   r <- liftBase $ readMVar var
 331
 332   let
 333     a = r ^. unNodeStory . at listId . _Just
 334     q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
 335     q_table = q ^. _PatchMap . at ngramsType . _Just
 336
 337   pure (Versioned (a ^. a_version) q_table)
 338
 339
 340
 341
 342 -- tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
 343 -- Apply the given patch to the DB and returns the patch to be applied on the
 344 -- client.
 345 -- TODO-ACCESS check
 346 tableNgramsPut :: ( HasNodeStory    env err m
 347                   , HasInvalidError     err
 348                   , HasSettings     env
 349                   , HasMail         env
 350                   )
 351                  => TabType
 352                  -> ListId
 353                  -> Versioned NgramsTablePatch
 354                  -> m (Versioned NgramsTablePatch)
 355 tableNgramsPut tabType listId (Versioned p_version p_table)
 356   | p_table == mempty = do
 357       printDebug "[tableNgramsPut]" ("TableEmpty" :: Text)
 358       let ngramsType        = ngramsTypeFromTabType tabType
 359       tableNgramsPull listId ngramsType p_version
 360
 361   | otherwise         = do
 362       printDebug "[tableNgramsPut]" ("TableNonEmpty" :: Text)
 363       let ngramsType        = ngramsTypeFromTabType tabType
 364           (p, p_validity)   = PM.singleton ngramsType p_table
 365
 366       assertValid p_validity
 367
 368       ret <- commitStatePatch listId (Versioned p_version p)
 369         <&> v_data %~ (view (_PatchMap . at ngramsType . _Just))
 370
 371       pure ret
 372
 373
 374
 375 tableNgramsPostChartsAsync :: ( HasNodeStory env err m
 376                               , FlowCmdM     env err m
 377                               , HasNodeError err
 378                               , HasSettings env
 379                               )
 380                             => UpdateTableNgramsCharts
 381                             -> (JobLog -> m ())
 382                             -> m JobLog
 383 tableNgramsPostChartsAsync utn logStatus = do
 384       let tabType = utn ^. utn_tab_type
 385       let listId = utn ^. utn_list_id
 386
 387       node <- getNode listId
 388       let nId = node ^. node_id
 389           _uId = node ^. node_user_id
 390           mCId = node ^. node_parent_id
 391
 392       -- printDebug "[tableNgramsPostChartsAsync] tabType" tabType
 393       -- printDebug "[tableNgramsPostChartsAsync] listId" listId
 394
 395       case mCId of
 396         Nothing -> do
 397           printDebug "[tableNgramsPostChartsAsync] can't update charts, no parent, nId" nId
 398           pure $ jobLogFail $ jobLogInit 1
 399         Just cId -> do
 400           case tabType of
 401             Authors -> do
 402               -- printDebug "[tableNgramsPostChartsAsync] Authors, updating Pie, cId" cId
 403               (logRef, logRefSuccess, getRef) <- runJobLog 1 logStatus
 404               logRef
 405               _ <- Metrics.updatePie cId (Just listId) tabType Nothing
 406               logRefSuccess
 407
 408               getRef
 409             Institutes -> do
 410               -- printDebug "[tableNgramsPostChartsAsync] Institutes, updating Tree, cId" cId
 411               -- printDebug "[tableNgramsPostChartsAsync] updating tree StopTerm, cId" cId
 412               (logRef, logRefSuccess, getRef) <- runJobLog 3 logStatus
 413               logRef
 414               _ <- Metrics.updateTree cId (Just listId) tabType StopTerm
 415               -- printDebug "[tableNgramsPostChartsAsync] updating tree CandidateTerm, cId" cId
 416               logRefSuccess
 417               _ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
 418               -- printDebug "[tableNgramsPostChartsAsync] updating tree MapTerm, cId" cId
 419               logRefSuccess
 420               _ <- Metrics.updateTree cId (Just listId) tabType MapTerm
 421               logRefSuccess
 422
 423               getRef
 424             Sources -> do
 425               -- printDebug "[tableNgramsPostChartsAsync] Sources, updating chart, cId" cId
 426               (logRef, logRefSuccess, getRef) <- runJobLog 1 logStatus
 427               logRef
 428               _ <- Metrics.updatePie cId (Just listId) tabType Nothing
 429               logRefSuccess
 430
 431               getRef
 432             Terms -> do
 433               -- printDebug "[tableNgramsPostChartsAsync] Terms, updating Metrics (Histo), cId" cId
 434               (logRef, logRefSuccess, getRef) <- runJobLog 6 logStatus
 435               logRef
 436 {-
 437               _ <- Metrics.updateChart cId (Just listId) tabType Nothing
 438               logRefSuccess
 439               _ <- Metrics.updatePie cId (Just listId) tabType Nothing
 440               logRefSuccess
 441               _ <- Metrics.updateScatter cId (Just listId) tabType Nothing
 442               logRefSuccess
 443               _ <- Metrics.updateTree cId (Just listId) tabType StopTerm
 444               logRefSuccess
 445               _ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
 446               logRefSuccess
 447               _ <- Metrics.updateTree cId (Just listId) tabType MapTerm
 448 -}
 449               logRefSuccess
 450
 451               getRef
 452             _ -> do
 453               printDebug "[tableNgramsPostChartsAsync] no update for tabType = " tabType
 454               pure $ jobLogFail $ jobLogInit 1
 455
 456   {-
 457   { _ne_list        :: ListType
 458   If we merge the parents/children we can potentially create cycles!
 459   , _ne_parent      :: Maybe NgramsTerm
 460   , _ne_children    :: MSet NgramsTerm
 461   }
 462   -}
 463
 464 getNgramsTableMap :: HasNodeStory env err m
 465                   => NodeId
 466                   -> TableNgrams.NgramsType
 467                   -> m (Versioned NgramsTableMap)
 468 getNgramsTableMap nodeId ngramsType = do
 469   v    <- getNodeStoryVar [nodeId]
 470   repo <- liftBase $ readMVar v
 471   pure $ Versioned (repo ^. unNodeStory . at nodeId . _Just . a_version)
 472                    (repo ^. unNodeStory . at nodeId . _Just . a_state . at ngramsType . _Just)
 473
 474
 475 dumpJsonTableMap :: HasNodeStory env err m
 476                  => Text
 477                  -> NodeId
 478                  -> TableNgrams.NgramsType
 479                  -> m ()
 480 dumpJsonTableMap fpath nodeId ngramsType = do
 481   m <- getNgramsTableMap nodeId ngramsType
 482   liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m)
 483   pure ()
 484
 485
 486 type MinSize = Int
 487 type MaxSize = Int
 488
 489 -- | TODO Errors management
 490 --  TODO: polymorphic for Annuaire or Corpus or ...
 491 -- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
 492 -- TODO: should take only one ListId
 493
 494
 495 getTableNgrams :: forall env err m.
 496                   (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
 497                => NodeType -> NodeId -> TabType
 498                -> ListId   -> Limit  -> Maybe Offset
 499                -> Maybe ListType
 500                -> Maybe MinSize -> Maybe MaxSize
 501                -> Maybe OrderBy
 502                -> (NgramsTerm -> Bool)
 503                -> m (VersionedWithCount NgramsTable)
 504 getTableNgrams _nType nId tabType listId limit_ offset
 505                listType minSize maxSize orderBy searchQuery = do
 506
 507   t0 <- getTime
 508   -- lIds <- selectNodesWithUsername NodeList userMaster
 509   let
 510     ngramsType = ngramsTypeFromTabType tabType
 511     offset'  = maybe 0 identity offset
 512     listType' = maybe (const True) (==) listType
 513     minSize'  = maybe (const True) (<=) minSize
 514     maxSize'  = maybe (const True) (>=) maxSize
 515
 516     selected_node n = minSize'     s
 517                    && maxSize'     s
 518                    && searchQuery  (n ^. ne_ngrams)
 519                    && listType'    (n ^. ne_list)
 520       where
 521         s = n ^. ne_size
 522
 523     selected_inner roots n = maybe False (`Set.member` roots) (n ^. ne_root)
 524
 525     ---------------------------------------
 526     sortOnOrder Nothing          = sortOnOrder (Just ScoreDesc)
 527     sortOnOrder (Just TermAsc)   = List.sortOn $ view ne_ngrams
 528     sortOnOrder (Just TermDesc)  = List.sortOn $ Down . view ne_ngrams
 529     sortOnOrder (Just ScoreAsc)  = List.sortOn $ view ne_occurrences
 530     sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view ne_occurrences
 531
 532     ---------------------------------------
 533     filteredNodes :: Map NgramsTerm NgramsElement -> [NgramsElement]
 534     filteredNodes tableMap = rootOf <$> list & filter selected_node
 535       where
 536         rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root")
 537                                               (tableMap ^. at r)
 538                              )
 539                              (ne ^. ne_root)
 540         list = tableMap ^.. each
 541
 542     ---------------------------------------
 543     selectAndPaginate :: Map NgramsTerm NgramsElement -> [NgramsElement]
 544     selectAndPaginate tableMap = roots <> inners
 545       where
 546         list = tableMap ^.. each
 547         rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root")
 548                                               (tableMap ^. at r)
 549                              )
 550                              (ne ^. ne_root)
 551         selected_nodes = list & take limit_
 552                               . drop offset'
 553                               . filter selected_node
 554                               . sortOnOrder orderBy
 555         roots = rootOf <$> selected_nodes
 556         rootsSet = Set.fromList (_ne_ngrams <$> roots)
 557         inners = list & filter (selected_inner rootsSet)
 558
 559     ---------------------------------------
 560     setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
 561     setScores False table = pure table
 562     setScores True  table = do
 563       let ngrams_terms = table ^.. each . ne_ngrams
 564       -- printDebug "ngrams_terms" ngrams_terms
 565       t1 <- getTime
 566       occurrences <- getOccByNgramsOnlyFast' nId
 567                                              listId
 568                                             ngramsType
 569                                             ngrams_terms
 570       --printDebug "occurrences" occurrences
 571       t2 <- getTime
 572       liftBase $ hprint stderr
 573         ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n")
 574         (length ngrams_terms) t1 t2
 575       let
 576         setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
 577
 578       pure $ table & each %~ setOcc
 579     ---------------------------------------
 580
 581   -- lists <- catMaybes <$> listsWith userMaster
 582   -- trace (show lists) $
 583   -- getNgramsTableMap ({-lists <>-} listIds) ngramsType
 584
 585
 586   let scoresNeeded = needsScores orderBy
 587   tableMap1 <- getNgramsTableMap listId ngramsType
 588   t1 <- getTime
 589
 590   tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
 591                                     . Map.mapWithKey ngramsElementFromRepo
 592
 593   fltr <- tableMap2 & v_data %%~ fmap NgramsTable . setScores (not scoresNeeded)
 594                                                   . filteredNodes
 595
 596   let fltrCount = length $ fltr ^. v_data . _NgramsTable
 597
 598   t2 <- getTime
 599   tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
 600                                     . setScores (not scoresNeeded)
 601                                     . selectAndPaginate
 602   t3 <- getTime
 603   liftBase $ hprint stderr
 604             ("getTableNgrams total=" % hasTime
 605                           % " map1=" % hasTime
 606                           % " map2=" % hasTime
 607                           % " map3=" % hasTime
 608                           % " sql="  % (if scoresNeeded then "map2" else "map3")
 609                           % "\n"
 610             ) t0 t3 t0 t1 t1 t2 t2 t3
 611   pure $ toVersionedWithCount fltrCount tableMap3
 612
 613
 614
 615 scoresRecomputeTableNgrams :: forall env err m.
 616   (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
 617   => NodeId -> TabType -> ListId -> m Int
 618 scoresRecomputeTableNgrams nId tabType listId = do
 619   tableMap <- getNgramsTableMap listId ngramsType
 620   _ <- tableMap & v_data %%~ setScores
 621                            . Map.mapWithKey ngramsElementFromRepo
 622
 623   pure $ 1
 624   where
 625     ngramsType = ngramsTypeFromTabType tabType
 626
 627     setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t
 628     setScores table = do
 629       let ngrams_terms = table ^.. each . ne_ngrams
 630       occurrences <- getOccByNgramsOnlyFast' nId
 631                                              listId
 632                                             ngramsType
 633                                             ngrams_terms
 634       let
 635         setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
 636
 637       pure $ table & each %~ setOcc
 638
 639
 640
 641
 642 -- APIs
 643
 644 -- TODO: find a better place for the code above, All APIs stay here
 645
 646 data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
 647              deriving (Generic, Enum, Bounded, Read, Show)
 648
 649 instance FromHttpApiData OrderBy
 650   where
 651     parseUrlPiece "TermAsc"   = pure TermAsc
 652     parseUrlPiece "TermDesc"  = pure TermDesc
 653     parseUrlPiece "ScoreAsc"  = pure ScoreAsc
 654     parseUrlPiece "ScoreDesc" = pure ScoreDesc
 655     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 656
 657 instance ToHttpApiData OrderBy where
 658   toUrlPiece = pack . show
 659
 660 instance ToParamSchema OrderBy
 661 instance FromJSON  OrderBy
 662 instance ToJSON    OrderBy
 663 instance ToSchema  OrderBy
 664 instance Arbitrary OrderBy
 665   where
 666     arbitrary = elements [minBound..maxBound]
 667
 668 needsScores :: Maybe OrderBy -> Bool
 669 needsScores (Just ScoreAsc)  = True
 670 needsScores (Just ScoreDesc) = True
 671 needsScores _ = False
 672
 673 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 674                       :> QueryParamR "ngramsType"  TabType
 675                       :> QueryParamR "list"        ListId
 676                       :> QueryParamR "limit"       Limit
 677                       :> QueryParam  "offset"      Offset
 678                       :> QueryParam  "listType"    ListType
 679                       :> QueryParam  "minTermSize" MinSize
 680                       :> QueryParam  "maxTermSize" MaxSize
 681                       :> QueryParam  "orderBy"     OrderBy
 682                       :> QueryParam  "search"      Text
 683                       :> Get    '[JSON] (VersionedWithCount NgramsTable)
 684
 685 type TableNgramsApiPut = Summary " Table Ngrams API Change"
 686                        :> QueryParamR "ngramsType" TabType
 687                        :> QueryParamR "list"       ListId
 688                        :> ReqBody '[JSON] (Versioned NgramsTablePatch)
 689                        :> Put     '[JSON] (Versioned NgramsTablePatch)
 690
 691 type RecomputeScoresNgramsApiGet = Summary " Recompute scores for ngrams table"
 692                        :> QueryParamR "ngramsType"  TabType
 693                        :> QueryParamR "list"        ListId
 694                        :> "recompute" :> Post '[JSON] Int
 695
 696 type TableNgramsApiGetVersion = Summary " Table Ngrams API Get Version"
 697                       :> QueryParamR "ngramsType"  TabType
 698                       :> QueryParamR "list"        ListId
 699                       :> Get    '[JSON] Version
 700
 701 type TableNgramsApi =  TableNgramsApiGet
 702                   :<|> TableNgramsApiPut
 703                   :<|> RecomputeScoresNgramsApiGet
 704                   :<|> "version" :> TableNgramsApiGetVersion
 705                   :<|> TableNgramsAsyncApi
 706
 707 type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
 708                            :> "async"
 709                            :> "charts"
 710                            :> "update"
 711                            :> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog
 712
 713 getTableNgramsCorpus :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
 714                => NodeId
 715                -> TabType
 716                -> ListId
 717                -> Limit
 718                -> Maybe Offset
 719                -> Maybe ListType
 720                -> Maybe MinSize -> Maybe MaxSize
 721                -> Maybe OrderBy
 722                -> Maybe Text -- full text search
 723                -> m (VersionedWithCount NgramsTable)
 724 getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
 725   getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
 726     where
 727       searchQuery (NgramsTerm nt) = maybe (const True) isInfixOf mt nt
 728
 729
 730
 731 getTableNgramsVersion :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
 732                => NodeId
 733                -> TabType
 734                -> ListId
 735                -> m Version
 736 getTableNgramsVersion _nId _tabType listId = currentVersion listId
 737
 738
 739
 740   -- TODO: limit?
 741   -- Versioned { _v_version = v } <- getTableNgramsCorpus nId tabType listId 100000 Nothing Nothing Nothing Nothing Nothing Nothing
 742   -- This line above looks like a waste of computation to finally get only the version.
 743   -- See the comment about listNgramsChangedSince.
 744
 745
 746 -- | Text search is deactivated for now for ngrams by doc only
 747 getTableNgramsDoc :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
 748                => DocId -> TabType
 749                -> ListId -> Limit -> Maybe Offset
 750                -> Maybe ListType
 751                -> Maybe MinSize -> Maybe MaxSize
 752                -> Maybe OrderBy
 753                -> Maybe Text -- full text search
 754                -> m (VersionedWithCount NgramsTable)
 755 getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do
 756   ns <- selectNodesWithUsername NodeList userMaster
 757   let ngramsType = ngramsTypeFromTabType tabType
 758   ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
 759   let searchQuery (NgramsTerm nt) = flip S.member (S.fromList ngs) nt
 760   getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
 761
 762
 763
 764 apiNgramsTableCorpus :: ( GargServerC env err m
 765                         )
 766                      => NodeId -> ServerT TableNgramsApi m
 767 apiNgramsTableCorpus cId =  getTableNgramsCorpus       cId
 768                        :<|> tableNgramsPut
 769                        :<|> scoresRecomputeTableNgrams cId
 770                        :<|> getTableNgramsVersion      cId
 771                        :<|> apiNgramsAsync             cId
 772
 773 apiNgramsTableDoc :: ( GargServerC env err m
 774                      )
 775                   => DocId -> ServerT TableNgramsApi m
 776 apiNgramsTableDoc dId =  getTableNgramsDoc          dId
 777                     :<|> tableNgramsPut
 778                     :<|> scoresRecomputeTableNgrams dId
 779                     :<|> getTableNgramsVersion      dId
 780                     :<|> apiNgramsAsync             dId
 781
 782 apiNgramsAsync :: NodeId -> GargServer TableNgramsAsyncApi
 783 apiNgramsAsync _dId =
 784   serveJobsAPI $
 785     JobFunction $ \i log ->
 786       let
 787         log' x = do
 788           printDebug "tableNgramsPostChartsAsync" x
 789           liftBase $ log x
 790       in tableNgramsPostChartsAsync i log'
 791
 792 -- Did the given list of ngrams changed since the given version?
 793 -- The returned value is versioned boolean value, meaning that one always retrieve the
 794 -- latest version.
 795 -- If the given version is negative then one simply receive the latest version and True.
 796 -- Using this function is more precise than simply comparing the latest version number
 797 -- with the local version number. Indeed there might be no change to this particular list
 798 -- and still the version number has changed because of other lists.
 799 --
 800 -- Here the added value is to make a compromise between precision, computation, and bandwidth:
 801 -- * currentVersion: good computation, good bandwidth, bad precision.
 802 -- * listNgramsChangedSince: good precision, good bandwidth, bad computation.
 803 -- * tableNgramsPull: good precision, good bandwidth (if you use the received data!), bad computation.
 804 listNgramsChangedSince :: HasNodeStory env err m
 805                        => ListId -> TableNgrams.NgramsType -> Version -> m (Versioned Bool)
 806 listNgramsChangedSince listId ngramsType version
 807   | version < 0 =
 808       Versioned <$> currentVersion listId <*> pure True
 809   | otherwise   =
 810       tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
 811
 812