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 TemplateHaskell   #-}
  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)
  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
 280 -- tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
 281 commitStatePatch :: RepoCmdM env err m => Versioned NgramsStatePatch -> m (Versioned NgramsStatePatch)
 282 commitStatePatch (Versioned p_version p) = do
 283   var <- view repoVar
 284   vq' <- liftBase $ modifyMVar var $ \r -> do
 285     let
 286       q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
 287       (p', q') = transformWith ngramsStatePatchConflictResolution p q
 288       r' = r & r_version +~ 1
 289              & r_state   %~ act p'
 290              & r_history %~ (p' :)
 291     {-
 292     -- Ideally we would like to check these properties. However:
 293     -- * They should be checked only to debug the code. The client data
 294     --   should be able to trigger these.
 295     -- * What kind of error should they throw (we are in IO here)?
 296     -- * Should we keep modifyMVar?
 297     -- * Should we throw the validation in an Exception, catch it around
 298     --   modifyMVar and throw it back as an Error?
 299     assertValid $ transformable p q
 300     assertValid $ applicable p' (r ^. r_state)
 301     -}
 302     pure (r', Versioned (r' ^. r_version) q')
 303
 304   saveRepo
 305   pure vq'
 306
 307 -- This is a special case of tableNgramsPut where the input patch is empty.
 308 tableNgramsPull :: RepoCmdM env err m
 309                 => ListId
 310                 -> TableNgrams.NgramsType
 311                 -> Version
 312                 -> m (Versioned NgramsTablePatch)
 313 tableNgramsPull listId ngramsType p_version = do
 314   var <- view repoVar
 315   r <- liftBase $ readMVar var
 316
 317   let
 318     q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
 319     q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
 320
 321   pure (Versioned (r ^. r_version) q_table)
 322
 323 -- Apply the given patch to the DB and returns the patch to be applied on the
 324 -- client.
 325 -- TODO-ACCESS check
 326 tableNgramsPut :: ( FlowCmdM env err m
 327                   , HasSettings env
 328                   )
 329                  => TabType
 330                  -> ListId
 331                  -> Versioned NgramsTablePatch
 332                  -> m (Versioned NgramsTablePatch)
 333 tableNgramsPut tabType listId (Versioned p_version p_table)
 334   | p_table == mempty = do
 335       let ngramsType        = ngramsTypeFromTabType tabType
 336       tableNgramsPull listId ngramsType p_version
 337
 338   | otherwise         = do
 339       let ngramsType        = ngramsTypeFromTabType tabType
 340           (p0, p0_validity) = PM.singleton listId p_table
 341           (p, p_validity)   = PM.singleton ngramsType p0
 342
 343       assertValid p0_validity
 344       assertValid p_validity
 345
 346       ret <- commitStatePatch (Versioned p_version p)
 347         <&> v_data %~ (view (_PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just))
 348
 349       pure ret
 350
 351
 352 tableNgramsPostChartsAsync :: ( FlowCmdM env err m
 353                               , HasNodeError err
 354                               , HasSettings env
 355                               )
 356                             => UpdateTableNgramsCharts
 357                             -> (JobLog -> m ())
 358                             -> m JobLog
 359 tableNgramsPostChartsAsync utn logStatus = do
 360       let tabType = utn ^. utn_tab_type
 361       let listId = utn ^. utn_list_id
 362
 363       node <- getNode listId
 364       let nId = node ^. node_id
 365           _uId = node ^. node_userId
 366           mCId = node ^. node_parentId
 367
 368       printDebug "[tableNgramsPut] tabType" tabType
 369       printDebug "[tableNgramsPut] listId" listId
 370
 371       case mCId of
 372         Nothing -> do
 373           printDebug "[tableNgramsPut] can't update charts, no parent, nId" nId
 374           pure $ jobLogFail $ jobLogInit 1
 375         Just cId -> do
 376           case tabType of
 377             Authors -> do
 378               -- printDebug "[tableNgramsPut] Authors, updating Pie, cId" cId
 379               (logRef, logRefSuccess, getRef) <- runJobLog 1 logStatus
 380               logRef
 381               _ <- Metrics.updatePie cId (Just listId) tabType Nothing
 382               logRefSuccess
 383
 384               getRef
 385             Institutes -> do
 386               -- printDebug "[tableNgramsPut] Institutes, updating Tree, cId" cId
 387               -- printDebug "[tableNgramsPut] updating tree StopTerm, cId" cId
 388               (logRef, logRefSuccess, getRef) <- runJobLog 3 logStatus
 389               logRef
 390               _ <- Metrics.updateTree cId (Just listId) tabType StopTerm
 391               -- printDebug "[tableNgramsPut] updating tree CandidateTerm, cId" cId
 392               logRefSuccess
 393               _ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
 394               -- printDebug "[tableNgramsPut] updating tree MapTerm, cId" cId
 395               logRefSuccess
 396               _ <- Metrics.updateTree cId (Just listId) tabType MapTerm
 397               logRefSuccess
 398
 399               getRef
 400             Sources -> do
 401               -- printDebug "[tableNgramsPut] Sources, updating chart, cId" cId
 402               (logRef, logRefSuccess, getRef) <- runJobLog 1 logStatus
 403               logRef
 404               _ <- Metrics.updatePie cId (Just listId) tabType Nothing
 405               logRefSuccess
 406
 407               getRef
 408             Terms -> do
 409               -- printDebug "[tableNgramsPut] Terms, updating Metrics (Histo), cId" cId
 410               (logRef, logRefSuccess, getRef) <- runJobLog 6 logStatus
 411               logRef
 412               _ <- Metrics.updateChart cId (Just listId) tabType Nothing
 413               logRefSuccess
 414               _ <- Metrics.updatePie cId (Just listId) tabType Nothing
 415               logRefSuccess
 416               _ <- Metrics.updateScatter cId (Just listId) tabType Nothing
 417               logRefSuccess
 418               _ <- Metrics.updateTree cId (Just listId) tabType StopTerm
 419               logRefSuccess
 420               _ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
 421               logRefSuccess
 422               _ <- Metrics.updateTree cId (Just listId) tabType MapTerm
 423               logRefSuccess
 424
 425               getRef
 426             _ -> do
 427               printDebug "[tableNgramsPut] no update for tabType = " tabType
 428               pure $ jobLogFail $ jobLogInit 1
 429
 430   {-
 431   { _ne_list        :: ListType
 432   If we merge the parents/children we can potentially create cycles!
 433   , _ne_parent      :: Maybe NgramsTerm
 434   , _ne_children    :: MSet NgramsTerm
 435   }
 436   -}
 437
 438 getNgramsTableMap :: RepoCmdM env err m
 439                   => NodeId
 440                   -> TableNgrams.NgramsType
 441                   -> m (Versioned NgramsTableMap)
 442 getNgramsTableMap nodeId ngramsType = do
 443   v    <- view repoVar
 444   repo <- liftBase $ readMVar v
 445   pure $ Versioned (repo ^. r_version)
 446                    (repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
 447
 448 dumpJsonTableMap :: RepoCmdM env err m
 449                  => Text
 450                  -> NodeId
 451                  -> TableNgrams.NgramsType
 452                  -> m ()
 453 dumpJsonTableMap fpath nodeId ngramsType = do
 454   m <- getNgramsTableMap nodeId ngramsType
 455   liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m)
 456   pure ()
 457
 458 type MinSize = Int
 459 type MaxSize = Int
 460
 461 -- | TODO Errors management
 462 --  TODO: polymorphic for Annuaire or Corpus or ...
 463 -- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
 464 -- TODO: should take only one ListId
 465
 466 getTime' :: MonadBase IO m => m TimeSpec
 467 getTime' = liftBase $ getTime ProcessCPUTime
 468
 469
 470 getTableNgrams :: forall env err m.
 471                   (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
 472                => NodeType -> NodeId -> TabType
 473                -> ListId -> Limit -> Maybe Offset
 474                -> Maybe ListType
 475                -> Maybe MinSize -> Maybe MaxSize
 476                -> Maybe OrderBy
 477                -> (NgramsTerm -> Bool)
 478                -> m (Versioned NgramsTable)
 479 getTableNgrams _nType nId tabType listId limit_ offset
 480                listType minSize maxSize orderBy searchQuery = do
 481
 482   t0 <- getTime'
 483   -- lIds <- selectNodesWithUsername NodeList userMaster
 484   let
 485     ngramsType = ngramsTypeFromTabType tabType
 486     offset'  = maybe 0 identity offset
 487     listType' = maybe (const True) (==) listType
 488     minSize'  = maybe (const True) (<=) minSize
 489     maxSize'  = maybe (const True) (>=) maxSize
 490
 491     selected_node n = minSize'     s
 492                    && maxSize'     s
 493                    && searchQuery  (n ^. ne_ngrams)
 494                    && listType'    (n ^. ne_list)
 495       where
 496         s = n ^. ne_size
 497
 498     selected_inner roots n = maybe False (`Set.member` roots) (n ^. ne_root)
 499
 500     ---------------------------------------
 501     sortOnOrder Nothing = identity
 502     sortOnOrder (Just TermAsc)   = List.sortOn $ view ne_ngrams
 503     sortOnOrder (Just TermDesc)  = List.sortOn $ Down . view ne_ngrams
 504     sortOnOrder (Just ScoreAsc)  = List.sortOn $ view ne_occurrences
 505     sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view ne_occurrences
 506
 507     ---------------------------------------
 508     selectAndPaginate :: Map NgramsTerm NgramsElement -> [NgramsElement]
 509     selectAndPaginate tableMap = roots <> inners
 510       where
 511         list = tableMap ^.. each
 512         rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root") (tableMap ^. at r))
 513                              (ne ^. ne_root)
 514         selected_nodes = list & take limit_
 515                               . drop offset'
 516                               . filter selected_node
 517                               . sortOnOrder orderBy
 518         roots = rootOf <$> selected_nodes
 519         rootsSet = Set.fromList (_ne_ngrams <$> roots)
 520         inners = list & filter (selected_inner rootsSet)
 521
 522     ---------------------------------------
 523     setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
 524     setScores False table = pure table
 525     setScores True  table = do
 526       let ngrams_terms = unNgramsTerm <$> (table ^.. each . ne_ngrams)
 527       t1 <- getTime'
 528       occurrences <- getOccByNgramsOnlyFast' nId
 529                                              listId
 530                                             ngramsType
 531                                             ngrams_terms
 532       t2 <- getTime'
 533       liftBase $ hprint stderr
 534         ("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
 535         (length ngrams_terms) t1 t2
 536       {-
 537       occurrences <- getOccByNgramsOnlySlow nType nId
 538                                             (lIds <> [listId])
 539                                             ngramsType
 540                                             ngrams_terms
 541       -}
 542       let
 543         setOcc ne = ne & ne_occurrences .~ sumOf (at (unNgramsTerm (ne ^. ne_ngrams)) . _Just) occurrences
 544
 545       pure $ table & each %~ setOcc
 546     ---------------------------------------
 547
 548   -- lists <- catMaybes <$> listsWith userMaster
 549   -- trace (show lists) $
 550   -- getNgramsTableMap ({-lists <>-} listIds) ngramsType
 551
 552   let scoresNeeded = needsScores orderBy
 553   tableMap1 <- getNgramsTableMap listId ngramsType
 554   t1 <- getTime'
 555   tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
 556                                     . Map.mapWithKey ngramsElementFromRepo
 557   t2 <- getTime'
 558   tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
 559                                     . setScores (not scoresNeeded)
 560                                     . selectAndPaginate
 561   t3 <- getTime'
 562   liftBase $ hprint stderr
 563             ("getTableNgrams total=" % timeSpecs
 564                           % " map1=" % timeSpecs
 565                           % " map2=" % timeSpecs
 566                           % " map3=" % timeSpecs
 567                           % " sql="  % (if scoresNeeded then "map2" else "map3")
 568                           % "\n"
 569             ) t0 t3 t0 t1 t1 t2 t2 t3
 570   pure tableMap3
 571
 572
 573 scoresRecomputeTableNgrams :: forall env err m. (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env) => NodeId -> TabType -> ListId -> m Int
 574 scoresRecomputeTableNgrams nId tabType listId = do
 575   tableMap <- getNgramsTableMap listId ngramsType
 576   _ <- tableMap & v_data %%~ setScores
 577                            . Map.mapWithKey ngramsElementFromRepo
 578
 579   pure $ 1
 580   where
 581     ngramsType = ngramsTypeFromTabType tabType
 582
 583     setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t
 584     setScores table = do
 585       let ngrams_terms = unNgramsTerm <$> (table ^.. each . ne_ngrams)
 586       occurrences <- getOccByNgramsOnlyFast' nId
 587                                              listId
 588                                             ngramsType
 589                                             ngrams_terms
 590       let
 591         setOcc ne = ne & ne_occurrences .~ sumOf (at (unNgramsTerm (ne ^. ne_ngrams)) . _Just) occurrences
 592
 593       pure $ table & each %~ setOcc
 594
 595
 596
 597 -- APIs
 598
 599 -- TODO: find a better place for the code above, All APIs stay here
 600
 601 data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
 602              deriving (Generic, Enum, Bounded, Read, Show)
 603
 604 instance FromHttpApiData OrderBy
 605   where
 606     parseUrlPiece "TermAsc"   = pure TermAsc
 607     parseUrlPiece "TermDesc"  = pure TermDesc
 608     parseUrlPiece "ScoreAsc"  = pure ScoreAsc
 609     parseUrlPiece "ScoreDesc" = pure ScoreDesc
 610     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 611
 612
 613 instance ToParamSchema OrderBy
 614 instance FromJSON  OrderBy
 615 instance ToJSON    OrderBy
 616 instance ToSchema  OrderBy
 617 instance Arbitrary OrderBy
 618   where
 619     arbitrary = elements [minBound..maxBound]
 620
 621 needsScores :: Maybe OrderBy -> Bool
 622 needsScores (Just ScoreAsc)  = True
 623 needsScores (Just ScoreDesc) = True
 624 needsScores _ = False
 625
 626 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 627                       :> QueryParamR "ngramsType"  TabType
 628                       :> QueryParamR "list"        ListId
 629                       :> QueryParamR "limit"       Limit
 630                       :> QueryParam  "offset"      Offset
 631                       :> QueryParam  "listType"    ListType
 632                       :> QueryParam  "minTermSize" MinSize
 633                       :> QueryParam  "maxTermSize" MaxSize
 634                       :> QueryParam  "orderBy"     OrderBy
 635                       :> QueryParam  "search"      Text
 636                       :> Get    '[JSON] (Versioned NgramsTable)
 637
 638 type TableNgramsApiPut = Summary " Table Ngrams API Change"
 639                        :> QueryParamR "ngramsType" TabType
 640                        :> QueryParamR "list"       ListId
 641                        :> ReqBody '[JSON] (Versioned NgramsTablePatch)
 642                        :> Put     '[JSON] (Versioned NgramsTablePatch)
 643
 644 type RecomputeScoresNgramsApiGet = Summary " Recompute scores for ngrams table"
 645                        :> QueryParamR "ngramsType"  TabType
 646                        :> QueryParamR "list"        ListId
 647                        :> "recompute" :> Post '[JSON] Int
 648
 649 type TableNgramsApiGetVersion = Summary " Table Ngrams API Get Version"
 650                       :> QueryParamR "ngramsType"  TabType
 651                       :> QueryParamR "list"        ListId
 652                       :> Get    '[JSON] Version
 653
 654 type TableNgramsApi =  TableNgramsApiGet
 655                   :<|> TableNgramsApiPut
 656                   :<|> RecomputeScoresNgramsApiGet
 657                   :<|> "version" :> TableNgramsApiGetVersion
 658                   :<|> TableNgramsAsyncApi
 659
 660 type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
 661                            :> "async"
 662                            :> "charts"
 663                            :> "update"
 664                            :> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog
 665
 666 getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
 667                => NodeId
 668                -> TabType
 669                -> ListId
 670                -> Limit
 671                -> Maybe Offset
 672                -> Maybe ListType
 673                -> Maybe MinSize -> Maybe MaxSize
 674                -> Maybe OrderBy
 675                -> Maybe Text -- full text search
 676                -> m (Versioned NgramsTable)
 677 getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
 678   getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
 679     where
 680       searchQuery (NgramsTerm nt) = maybe (const True) isInfixOf mt nt
 681
 682 getTableNgramsVersion :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
 683                => NodeId
 684                -> TabType
 685                -> ListId
 686                -> m Version
 687 getTableNgramsVersion _nId _tabType _listId = currentVersion
 688   -- TODO: limit?
 689   -- Versioned { _v_version = v } <- getTableNgramsCorpus nId tabType listId 100000 Nothing Nothing Nothing Nothing Nothing Nothing
 690   -- This line above looks like a waste of computation to finally get only the version.
 691   -- See the comment about listNgramsChangedSince.
 692
 693
 694 -- | Text search is deactivated for now for ngrams by doc only
 695 getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
 696                => DocId -> TabType
 697                -> ListId -> Limit -> Maybe Offset
 698                -> Maybe ListType
 699                -> Maybe MinSize -> Maybe MaxSize
 700                -> Maybe OrderBy
 701                -> Maybe Text -- full text search
 702                -> m (Versioned NgramsTable)
 703 getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do
 704   ns <- selectNodesWithUsername NodeList userMaster
 705   let ngramsType = ngramsTypeFromTabType tabType
 706   ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
 707   let searchQuery (NgramsTerm nt) = flip S.member (S.fromList ngs) nt
 708   getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
 709
 710
 711
 712 apiNgramsTableCorpus :: ( GargServerC env err m
 713                         )
 714                      => NodeId -> ServerT TableNgramsApi m
 715 apiNgramsTableCorpus cId =  getTableNgramsCorpus cId
 716                        :<|> tableNgramsPut
 717                        :<|> scoresRecomputeTableNgrams cId
 718                        :<|> getTableNgramsVersion cId
 719                        :<|> apiNgramsAsync cId
 720
 721 apiNgramsTableDoc :: ( GargServerC env err m
 722                      )
 723                   => DocId -> ServerT TableNgramsApi m
 724 apiNgramsTableDoc dId =  getTableNgramsDoc dId
 725                     :<|> tableNgramsPut
 726                     :<|> scoresRecomputeTableNgrams dId
 727                     :<|> getTableNgramsVersion dId
 728                     :<|> apiNgramsAsync dId
 729                     -- > index all the corpus accordingly (TODO AD)
 730
 731 apiNgramsAsync :: NodeId -> GargServer TableNgramsAsyncApi
 732 apiNgramsAsync _dId =
 733   serveJobsAPI $
 734     JobFunction $ \i log ->
 735       let
 736         log' x = do
 737           printDebug "tableNgramsPostChartsAsync" x
 738           liftBase $ log x
 739       in tableNgramsPostChartsAsync i log'
 740
 741 -- Did the given list of ngrams changed since the given version?
 742 -- The returned value is versioned boolean value, meaning that one always retrieve the
 743 -- latest version.
 744 -- If the given version is negative then one simply receive the latest version and True.
 745 -- Using this function is more precise than simply comparing the latest version number
 746 -- with the local version number. Indeed there might be no change to this particular list
 747 -- and still the version number has changed because of other lists.
 748 --
 749 -- Here the added value is to make a compromise between precision, computation, and bandwidth:
 750 -- * currentVersion: good computation, good bandwidth, bad precision.
 751 -- * listNgramsChangedSince: good precision, good bandwidth, bad computation.
 752 -- * tableNgramsPull: good precision, good bandwidth (if you use the received data!), bad computation.
 753 listNgramsChangedSince :: RepoCmdM env err m
 754                        => ListId -> TableNgrams.NgramsType -> Version -> m (Versioned Bool)
 755 listNgramsChangedSince listId ngramsType version
 756   | version < 0 =
 757       Versioned <$> currentVersion <*> pure True
 758   | otherwise   =
 759       tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)