src/Gargantext/API/Ngrams.hs

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