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 = identity
 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
 534     filteredNodes :: Map NgramsTerm NgramsElement -> [NgramsElement]
 535     filteredNodes tableMap = rootOf <$> list & filter selected_node
 536       where
 537         rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root")
 538                                               (tableMap ^. at r)
 539                              )
 540                              (ne ^. ne_root)
 541         list = tableMap ^.. each
 542
 543     ---------------------------------------
 544     selectAndPaginate :: Map NgramsTerm NgramsElement -> [NgramsElement]
 545     selectAndPaginate tableMap = roots <> inners
 546       where
 547         list = tableMap ^.. each
 548         rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root")
 549                                               (tableMap ^. at r)
 550                              )
 551                              (ne ^. ne_root)
 552         selected_nodes = list & take limit_
 553                               . drop offset'
 554                               . filter selected_node
 555                               . sortOnOrder orderBy
 556         roots = rootOf <$> selected_nodes
 557         rootsSet = Set.fromList (_ne_ngrams <$> roots)
 558         inners = list & filter (selected_inner rootsSet)
 559
 560     ---------------------------------------
 561     setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
 562     setScores False table = pure table
 563     setScores True  table = do
 564       let ngrams_terms = table ^.. each . ne_ngrams
 565       printDebug "ngrams_terms" ngrams_terms
 566       t1 <- getTime
 567       occurrences <- getOccByNgramsOnlyFast' nId
 568                                              listId
 569                                             ngramsType
 570                                             ngrams_terms
 571       printDebug "occurrences" occurrences
 572       t2 <- getTime
 573       liftBase $ hprint stderr
 574         ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n")
 575         (length ngrams_terms) t1 t2
 576       let
 577         setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
 578
 579       pure $ table & each %~ setOcc
 580     ---------------------------------------
 581
 582   -- lists <- catMaybes <$> listsWith userMaster
 583   -- trace (show lists) $
 584   -- getNgramsTableMap ({-lists <>-} listIds) ngramsType
 585
 586
 587   let scoresNeeded = needsScores orderBy
 588   tableMap1 <- getNgramsTableMap listId ngramsType
 589   t1 <- getTime
 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   let fltrCount = length $ fltr ^. v_data . _NgramsTable
 596
 597   t2 <- getTime
 598   tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
 599                                     . setScores (not scoresNeeded)
 600                                     . selectAndPaginate
 601   t3 <- getTime
 602   liftBase $ hprint stderr
 603             ("getTableNgrams total=" % hasTime
 604                           % " map1=" % hasTime
 605                           % " map2=" % hasTime
 606                           % " map3=" % hasTime
 607                           % " sql="  % (if scoresNeeded then "map2" else "map3")
 608                           % "\n"
 609             ) t0 t3 t0 t1 t1 t2 t2 t3
 610   pure $ toVersionedWithCount fltrCount tableMap3
 611
 612
 613
 614 scoresRecomputeTableNgrams :: forall env err m.
 615   (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
 616   => NodeId -> TabType -> ListId -> m Int
 617 scoresRecomputeTableNgrams nId tabType listId = do
 618   tableMap <- getNgramsTableMap listId ngramsType
 619   _ <- tableMap & v_data %%~ setScores
 620                            . Map.mapWithKey ngramsElementFromRepo
 621
 622   pure $ 1
 623   where
 624     ngramsType = ngramsTypeFromTabType tabType
 625
 626     setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t
 627     setScores table = do
 628       let ngrams_terms = table ^.. each . ne_ngrams
 629       occurrences <- getOccByNgramsOnlyFast' nId
 630                                              listId
 631                                             ngramsType
 632                                             ngrams_terms
 633       let
 634         setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
 635
 636       pure $ table & each %~ setOcc
 637
 638
 639
 640
 641 -- APIs
 642
 643 -- TODO: find a better place for the code above, All APIs stay here
 644
 645 data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
 646              deriving (Generic, Enum, Bounded, Read, Show)
 647
 648 instance FromHttpApiData OrderBy
 649   where
 650     parseUrlPiece "TermAsc"   = pure TermAsc
 651     parseUrlPiece "TermDesc"  = pure TermDesc
 652     parseUrlPiece "ScoreAsc"  = pure ScoreAsc
 653     parseUrlPiece "ScoreDesc" = pure ScoreDesc
 654     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 655
 656 instance ToHttpApiData OrderBy where
 657   toUrlPiece = pack . show
 658
 659 instance ToParamSchema OrderBy
 660 instance FromJSON  OrderBy
 661 instance ToJSON    OrderBy
 662 instance ToSchema  OrderBy
 663 instance Arbitrary OrderBy
 664   where
 665     arbitrary = elements [minBound..maxBound]
 666
 667 needsScores :: Maybe OrderBy -> Bool
 668 needsScores (Just ScoreAsc)  = True
 669 needsScores (Just ScoreDesc) = True
 670 needsScores _ = False
 671
 672 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 673                       :> QueryParamR "ngramsType"  TabType
 674                       :> QueryParamR "list"        ListId
 675                       :> QueryParamR "limit"       Limit
 676                       :> QueryParam  "offset"      Offset
 677                       :> QueryParam  "listType"    ListType
 678                       :> QueryParam  "minTermSize" MinSize
 679                       :> QueryParam  "maxTermSize" MaxSize
 680                       :> QueryParam  "orderBy"     OrderBy
 681                       :> QueryParam  "search"      Text
 682                       :> Get    '[JSON] (VersionedWithCount NgramsTable)
 683
 684 type TableNgramsApiPut = Summary " Table Ngrams API Change"
 685                        :> QueryParamR "ngramsType" TabType
 686                        :> QueryParamR "list"       ListId
 687                        :> ReqBody '[JSON] (Versioned NgramsTablePatch)
 688                        :> Put     '[JSON] (Versioned NgramsTablePatch)
 689
 690 type RecomputeScoresNgramsApiGet = Summary " Recompute scores for ngrams table"
 691                        :> QueryParamR "ngramsType"  TabType
 692                        :> QueryParamR "list"        ListId
 693                        :> "recompute" :> Post '[JSON] Int
 694
 695 type TableNgramsApiGetVersion = Summary " Table Ngrams API Get Version"
 696                       :> QueryParamR "ngramsType"  TabType
 697                       :> QueryParamR "list"        ListId
 698                       :> Get    '[JSON] Version
 699
 700 type TableNgramsApi =  TableNgramsApiGet
 701                   :<|> TableNgramsApiPut
 702                   :<|> RecomputeScoresNgramsApiGet
 703                   :<|> "version" :> TableNgramsApiGetVersion
 704                   :<|> TableNgramsAsyncApi
 705
 706 type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
 707                            :> "async"
 708                            :> "charts"
 709                            :> "update"
 710                            :> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog
 711
 712 getTableNgramsCorpus :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
 713                => NodeId
 714                -> TabType
 715                -> ListId
 716                -> Limit
 717                -> Maybe Offset
 718                -> Maybe ListType
 719                -> Maybe MinSize -> Maybe MaxSize
 720                -> Maybe OrderBy
 721                -> Maybe Text -- full text search
 722                -> m (VersionedWithCount NgramsTable)
 723 getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
 724   getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
 725     where
 726       searchQuery (NgramsTerm nt) = maybe (const True) isInfixOf mt nt
 727
 728
 729
 730 getTableNgramsVersion :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
 731                => NodeId
 732                -> TabType
 733                -> ListId
 734                -> m Version
 735 getTableNgramsVersion _nId _tabType listId = currentVersion listId
 736
 737
 738
 739   -- TODO: limit?
 740   -- Versioned { _v_version = v } <- getTableNgramsCorpus nId tabType listId 100000 Nothing Nothing Nothing Nothing Nothing Nothing
 741   -- This line above looks like a waste of computation to finally get only the version.
 742   -- See the comment about listNgramsChangedSince.
 743
 744
 745 -- | Text search is deactivated for now for ngrams by doc only
 746 getTableNgramsDoc :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
 747                => DocId -> TabType
 748                -> ListId -> Limit -> Maybe Offset
 749                -> Maybe ListType
 750                -> Maybe MinSize -> Maybe MaxSize
 751                -> Maybe OrderBy
 752                -> Maybe Text -- full text search
 753                -> m (VersionedWithCount NgramsTable)
 754 getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do
 755   ns <- selectNodesWithUsername NodeList userMaster
 756   let ngramsType = ngramsTypeFromTabType tabType
 757   ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
 758   let searchQuery (NgramsTerm nt) = flip S.member (S.fromList ngs) nt
 759   getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
 760
 761
 762
 763 apiNgramsTableCorpus :: ( GargServerC env err m
 764                         )
 765                      => NodeId -> ServerT TableNgramsApi m
 766 apiNgramsTableCorpus cId =  getTableNgramsCorpus       cId
 767                        :<|> tableNgramsPut
 768                        :<|> scoresRecomputeTableNgrams cId
 769                        :<|> getTableNgramsVersion      cId
 770                        :<|> apiNgramsAsync             cId
 771
 772 apiNgramsTableDoc :: ( GargServerC env err m
 773                      )
 774                   => DocId -> ServerT TableNgramsApi m
 775 apiNgramsTableDoc dId =  getTableNgramsDoc          dId
 776                     :<|> tableNgramsPut
 777                     :<|> scoresRecomputeTableNgrams dId
 778                     :<|> getTableNgramsVersion      dId
 779                     :<|> apiNgramsAsync             dId
 780
 781 apiNgramsAsync :: NodeId -> GargServer TableNgramsAsyncApi
 782 apiNgramsAsync _dId =
 783   serveJobsAPI $
 784     JobFunction $ \i log ->
 785       let
 786         log' x = do
 787           printDebug "tableNgramsPostChartsAsync" x
 788           liftBase $ log x
 789       in tableNgramsPostChartsAsync i log'
 790
 791 -- Did the given list of ngrams changed since the given version?
 792 -- The returned value is versioned boolean value, meaning that one always retrieve the
 793 -- latest version.
 794 -- If the given version is negative then one simply receive the latest version and True.
 795 -- Using this function is more precise than simply comparing the latest version number
 796 -- with the local version number. Indeed there might be no change to this particular list
 797 -- and still the version number has changed because of other lists.
 798 --
 799 -- Here the added value is to make a compromise between precision, computation, and bandwidth:
 800 -- * currentVersion: good computation, good bandwidth, bad precision.
 801 -- * listNgramsChangedSince: good precision, good bandwidth, bad computation.
 802 -- * tableNgramsPull: good precision, good bandwidth (if you use the received data!), bad computation.
 803 listNgramsChangedSince :: HasNodeStory env err m
 804                        => ListId -> TableNgrams.NgramsType -> Version -> m (Versioned Bool)
 805 listNgramsChangedSince listId ngramsType version
 806   | version < 0 =
 807       Versioned <$> currentVersion listId <*> pure True
 808   | otherwise   =
 809       tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
 810
 811