src/Gargantext/API/Ngrams.hs

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