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