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               _ <- Metrics.updateChart cId (Just listId) tabType Nothing
 423               logRefSuccess
 424               _ <- Metrics.updatePie cId (Just listId) tabType Nothing
 425               logRefSuccess
 426               _ <- Metrics.updateScatter cId (Just listId) tabType Nothing
 427               logRefSuccess
 428               _ <- Metrics.updateTree cId (Just listId) tabType StopTerm
 429               logRefSuccess
 430               _ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
 431               logRefSuccess
 432               _ <- Metrics.updateTree cId (Just listId) tabType MapTerm
 433               logRefSuccess
 434
 435               getRef
 436             _ -> do
 437               printDebug "[tableNgramsPut] no update for tabType = " tabType
 438               pure $ jobLogFail $ jobLogInit 1
 439
 440   {-
 441   { _ne_list        :: ListType
 442   If we merge the parents/children we can potentially create cycles!
 443   , _ne_parent      :: Maybe NgramsTerm
 444   , _ne_children    :: MSet NgramsTerm
 445   }
 446   -}
 447
 448 getNgramsTableMap :: RepoCmdM env err m
 449                   => NodeId
 450                   -> TableNgrams.NgramsType
 451                   -> m (Versioned NgramsTableMap)
 452 getNgramsTableMap nodeId ngramsType = do
 453   v    <- view repoVar
 454   repo <- liftBase $ readMVar v
 455   pure $ Versioned (repo ^. r_version)
 456                    (repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
 457
 458 dumpJsonTableMap :: RepoCmdM env err m
 459                  => Text
 460                  -> NodeId
 461                  -> TableNgrams.NgramsType
 462                  -> m ()
 463 dumpJsonTableMap fpath nodeId ngramsType = do
 464   m <- getNgramsTableMap nodeId ngramsType
 465   liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m)
 466   pure ()
 467
 468 type MinSize = Int
 469 type MaxSize = Int
 470
 471 -- | TODO Errors management
 472 --  TODO: polymorphic for Annuaire or Corpus or ...
 473 -- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
 474 -- TODO: should take only one ListId
 475
 476 getTime' :: MonadBase IO m => m TimeSpec
 477 getTime' = liftBase $ getTime ProcessCPUTime
 478
 479
 480 getTableNgrams :: forall env err m.
 481                   (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
 482                => NodeType -> NodeId -> TabType
 483                -> ListId -> Limit -> Maybe Offset
 484                -> Maybe ListType
 485                -> Maybe MinSize -> Maybe MaxSize
 486                -> Maybe OrderBy
 487                -> (NgramsTerm -> Bool)
 488                -> m (Versioned NgramsTable)
 489 getTableNgrams _nType nId tabType listId limit_ offset
 490                listType minSize maxSize orderBy searchQuery = do
 491
 492   t0 <- getTime'
 493   -- lIds <- selectNodesWithUsername NodeList userMaster
 494   let
 495     ngramsType = ngramsTypeFromTabType tabType
 496     offset'  = maybe 0 identity offset
 497     listType' = maybe (const True) (==) listType
 498     minSize'  = maybe (const True) (<=) minSize
 499     maxSize'  = maybe (const True) (>=) maxSize
 500
 501     selected_node n = minSize'     s
 502                    && maxSize'     s
 503                    && searchQuery  (n ^. ne_ngrams)
 504                    && listType'    (n ^. ne_list)
 505       where
 506         s = n ^. ne_size
 507
 508     selected_inner roots n = maybe False (`Set.member` roots) (n ^. ne_root)
 509
 510     ---------------------------------------
 511     sortOnOrder Nothing = identity
 512     sortOnOrder (Just TermAsc)   = List.sortOn $ view ne_ngrams
 513     sortOnOrder (Just TermDesc)  = List.sortOn $ Down . view ne_ngrams
 514     sortOnOrder (Just ScoreAsc)  = List.sortOn $ view ne_occurrences
 515     sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view ne_occurrences
 516
 517     ---------------------------------------
 518     selectAndPaginate :: Map NgramsTerm NgramsElement -> [NgramsElement]
 519     selectAndPaginate tableMap = roots <> inners
 520       where
 521         list = tableMap ^.. each
 522         rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root") (tableMap ^. at r))
 523                              (ne ^. ne_root)
 524         selected_nodes = list & take limit_
 525                               . drop offset'
 526                               . filter selected_node
 527                               . sortOnOrder orderBy
 528         roots = rootOf <$> selected_nodes
 529         rootsSet = Set.fromList (_ne_ngrams <$> roots)
 530         inners = list & filter (selected_inner rootsSet)
 531
 532     ---------------------------------------
 533     setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
 534     setScores False table = pure table
 535     setScores True  table = do
 536       let ngrams_terms = unNgramsTerm <$> (table ^.. each . ne_ngrams)
 537       t1 <- getTime'
 538       occurrences <- getOccByNgramsOnlyFast' nId
 539                                              listId
 540                                             ngramsType
 541                                             ngrams_terms
 542       t2 <- getTime'
 543       liftBase $ hprint stderr
 544         ("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
 545         (length ngrams_terms) t1 t2
 546       {-
 547       occurrences <- getOccByNgramsOnlySlow nType nId
 548                                             (lIds <> [listId])
 549                                             ngramsType
 550                                             ngrams_terms
 551       -}
 552       let
 553         setOcc ne = ne & ne_occurrences .~ sumOf (at (unNgramsTerm (ne ^. ne_ngrams)) . _Just) occurrences
 554
 555       pure $ table & each %~ setOcc
 556     ---------------------------------------
 557
 558   -- lists <- catMaybes <$> listsWith userMaster
 559   -- trace (show lists) $
 560   -- getNgramsTableMap ({-lists <>-} listIds) ngramsType
 561
 562   let scoresNeeded = needsScores orderBy
 563   tableMap1 <- getNgramsTableMap listId ngramsType
 564   t1 <- getTime'
 565   tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
 566                                     . Map.mapWithKey ngramsElementFromRepo
 567   t2 <- getTime'
 568   tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
 569                                     . setScores (not scoresNeeded)
 570                                     . selectAndPaginate
 571   t3 <- getTime'
 572   liftBase $ hprint stderr
 573             ("getTableNgrams total=" % timeSpecs
 574                           % " map1=" % timeSpecs
 575                           % " map2=" % timeSpecs
 576                           % " map3=" % timeSpecs
 577                           % " sql="  % (if scoresNeeded then "map2" else "map3")
 578                           % "\n"
 579             ) t0 t3 t0 t1 t1 t2 t2 t3
 580   pure tableMap3
 581
 582
 583 scoresRecomputeTableNgrams :: forall env err m. (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env) => NodeId -> TabType -> ListId -> m Int
 584 scoresRecomputeTableNgrams nId tabType listId = do
 585   tableMap <- getNgramsTableMap listId ngramsType
 586   _ <- tableMap & v_data %%~ setScores
 587                            . Map.mapWithKey ngramsElementFromRepo
 588
 589   pure $ 1
 590   where
 591     ngramsType = ngramsTypeFromTabType tabType
 592
 593     setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t
 594     setScores table = do
 595       let ngrams_terms = unNgramsTerm <$> (table ^.. each . ne_ngrams)
 596       occurrences <- getOccByNgramsOnlyFast' nId
 597                                              listId
 598                                             ngramsType
 599                                             ngrams_terms
 600       let
 601         setOcc ne = ne & ne_occurrences .~ sumOf (at (unNgramsTerm (ne ^. ne_ngrams)) . _Just) occurrences
 602
 603       pure $ table & each %~ setOcc
 604
 605
 606
 607 -- APIs
 608
 609 -- TODO: find a better place for the code above, All APIs stay here
 610
 611 data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
 612              deriving (Generic, Enum, Bounded, Read, Show)
 613
 614 instance FromHttpApiData OrderBy
 615   where
 616     parseUrlPiece "TermAsc"   = pure TermAsc
 617     parseUrlPiece "TermDesc"  = pure TermDesc
 618     parseUrlPiece "ScoreAsc"  = pure ScoreAsc
 619     parseUrlPiece "ScoreDesc" = pure ScoreDesc
 620     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 621
 622
 623 instance ToParamSchema OrderBy
 624 instance FromJSON  OrderBy
 625 instance ToJSON    OrderBy
 626 instance ToSchema  OrderBy
 627 instance Arbitrary OrderBy
 628   where
 629     arbitrary = elements [minBound..maxBound]
 630
 631 needsScores :: Maybe OrderBy -> Bool
 632 needsScores (Just ScoreAsc)  = True
 633 needsScores (Just ScoreDesc) = True
 634 needsScores _ = False
 635
 636 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 637                       :> QueryParamR "ngramsType"  TabType
 638                       :> QueryParamR "list"        ListId
 639                       :> QueryParamR "limit"       Limit
 640                       :> QueryParam  "offset"      Offset
 641                       :> QueryParam  "listType"    ListType
 642                       :> QueryParam  "minTermSize" MinSize
 643                       :> QueryParam  "maxTermSize" MaxSize
 644                       :> QueryParam  "orderBy"     OrderBy
 645                       :> QueryParam  "search"      Text
 646                       :> Get    '[JSON] (Versioned NgramsTable)
 647
 648 type TableNgramsApiPut = Summary " Table Ngrams API Change"
 649                        :> QueryParamR "ngramsType" TabType
 650                        :> QueryParamR "list"       ListId
 651                        :> ReqBody '[JSON] (Versioned NgramsTablePatch)
 652                        :> Put     '[JSON] (Versioned NgramsTablePatch)
 653
 654 type RecomputeScoresNgramsApiGet = Summary " Recompute scores for ngrams table"
 655                        :> QueryParamR "ngramsType"  TabType
 656                        :> QueryParamR "list"        ListId
 657                        :> "recompute" :> Post '[JSON] Int
 658
 659 type TableNgramsApiGetVersion = Summary " Table Ngrams API Get Version"
 660                       :> QueryParamR "ngramsType"  TabType
 661                       :> QueryParamR "list"        ListId
 662                       :> Get    '[JSON] Version
 663
 664 type TableNgramsApi =  TableNgramsApiGet
 665                   :<|> TableNgramsApiPut
 666                   :<|> RecomputeScoresNgramsApiGet
 667                   :<|> "version" :> TableNgramsApiGetVersion
 668                   :<|> TableNgramsAsyncApi
 669
 670 type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
 671                            :> "async"
 672                            :> "charts"
 673                            :> "update"
 674                            :> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog
 675
 676 getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
 677                => NodeId
 678                -> TabType
 679                -> ListId
 680                -> Limit
 681                -> Maybe Offset
 682                -> Maybe ListType
 683                -> Maybe MinSize -> Maybe MaxSize
 684                -> Maybe OrderBy
 685                -> Maybe Text -- full text search
 686                -> m (Versioned NgramsTable)
 687 getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
 688   getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
 689     where
 690       searchQuery (NgramsTerm nt) = maybe (const True) isInfixOf mt nt
 691
 692 getTableNgramsVersion :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
 693                => NodeId
 694                -> TabType
 695                -> ListId
 696                -> m Version
 697 getTableNgramsVersion _nId _tabType _listId = currentVersion
 698   -- TODO: limit?
 699   -- Versioned { _v_version = v } <- getTableNgramsCorpus nId tabType listId 100000 Nothing Nothing Nothing Nothing Nothing Nothing
 700   -- This line above looks like a waste of computation to finally get only the version.
 701   -- See the comment about listNgramsChangedSince.
 702
 703
 704 -- | Text search is deactivated for now for ngrams by doc only
 705 getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
 706                => DocId -> TabType
 707                -> ListId -> Limit -> Maybe Offset
 708                -> Maybe ListType
 709                -> Maybe MinSize -> Maybe MaxSize
 710                -> Maybe OrderBy
 711                -> Maybe Text -- full text search
 712                -> m (Versioned NgramsTable)
 713 getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do
 714   ns <- selectNodesWithUsername NodeList userMaster
 715   let ngramsType = ngramsTypeFromTabType tabType
 716   ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
 717   let searchQuery (NgramsTerm nt) = flip S.member (S.fromList ngs) nt
 718   getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
 719
 720
 721
 722 apiNgramsTableCorpus :: ( GargServerC env err m
 723                         )
 724                      => NodeId -> ServerT TableNgramsApi m
 725 apiNgramsTableCorpus cId =  getTableNgramsCorpus cId
 726                        :<|> tableNgramsPut
 727                        :<|> scoresRecomputeTableNgrams cId
 728                        :<|> getTableNgramsVersion cId
 729                        :<|> apiNgramsAsync cId
 730
 731 apiNgramsTableDoc :: ( GargServerC env err m
 732                      )
 733                   => DocId -> ServerT TableNgramsApi m
 734 apiNgramsTableDoc dId =  getTableNgramsDoc dId
 735                     :<|> tableNgramsPut
 736                     :<|> scoresRecomputeTableNgrams dId
 737                     :<|> getTableNgramsVersion dId
 738                     :<|> apiNgramsAsync dId
 739                     -- > index all the corpus accordingly (TODO AD)
 740
 741 apiNgramsAsync :: NodeId -> GargServer TableNgramsAsyncApi
 742 apiNgramsAsync _dId =
 743   serveJobsAPI $
 744     JobFunction $ \i log ->
 745       let
 746         log' x = do
 747           printDebug "tableNgramsPostChartsAsync" x
 748           liftBase $ log x
 749       in tableNgramsPostChartsAsync i log'
 750
 751 -- Did the given list of ngrams changed since the given version?
 752 -- The returned value is versioned boolean value, meaning that one always retrieve the
 753 -- latest version.
 754 -- If the given version is negative then one simply receive the latest version and True.
 755 -- Using this function is more precise than simply comparing the latest version number
 756 -- with the local version number. Indeed there might be no change to this particular list
 757 -- and still the version number has changed because of other lists.
 758 --
 759 -- Here the added value is to make a compromise between precision, computation, and bandwidth:
 760 -- * currentVersion: good computation, good bandwidth, bad precision.
 761 -- * listNgramsChangedSince: good precision, good bandwidth, bad computation.
 762 -- * tableNgramsPull: good precision, good bandwidth (if you use the received data!), bad computation.
 763 listNgramsChangedSince :: RepoCmdM env err m
 764                        => ListId -> TableNgrams.NgramsType -> Version -> m (Versioned Bool)
 765 listNgramsChangedSince listId ngramsType version
 766   | version < 0 =
 767       Versioned <$> currentVersion <*> pure True
 768   | otherwise   =
 769       tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)