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, (^.), (^..), (+~), (%~), (.~), msumOf, at, _Just, Each(..), (%%~), mapped, ifolded, to, 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 . to length)
 557     sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view (ne_occurrences . to length)
 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   tableMap <- getNgramsTable' nId listId ngramsType :: m (Versioned (Map NgramsTerm NgramsElement))
 588
 589   let fltr = tableMap & v_data %~ NgramsTable . filteredNodes :: Versioned NgramsTable
 590
 591   let fltrCount = length $ fltr ^. v_data . _NgramsTable
 592
 593   t2 <- getTime
 594   let tableMapSorted = over (v_data . _NgramsTable) ((withInners (tableMap ^. v_data)) . sortAndPaginate) fltr
 595   t3 <- getTime
 596   --printDebug "[getTableNgrams] tableMapSorted" tableMapSorted
 597   liftBase $ do
 598     hprint stderr
 599       ("getTableNgrams total=" % hasTime
 600         % " map1=" % hasTime
 601         % " map2=" % hasTime
 602         % " map3=" % hasTime
 603         % " sql="  % (if scoresNeeded then "map2" else "map3")
 604         % "\n"
 605       ) t0 t3 t0 t1 t1 t2 t2 t3
 606
 607     -- printDebug "[getTableNgrams] tableMapSorted" $ show tableMapSorted
 608   pure $ toVersionedWithCount fltrCount tableMapSorted
 609
 610
 611 -- | Helper function to get the ngrams table with scores.
 612 getNgramsTable' :: forall env err m.
 613                    ( HasNodeStory env err m
 614                    , HasNodeError err
 615                    , HasConnectionPool env
 616                    , HasConfig env
 617                    , HasMail env)
 618                 => NodeId
 619                 -> ListId
 620                 -> TableNgrams.NgramsType
 621                 -> m (Versioned (Map.Map NgramsTerm NgramsElement))
 622 getNgramsTable' nId listId ngramsType = do
 623   tableMap <- getNgramsTableMap listId ngramsType
 624   tableMap & v_data %%~ (setNgramsTableScores nId listId ngramsType)
 625                         . Map.mapWithKey ngramsElementFromRepo
 626
 627 -- | Helper function to set scores on an `NgramsTable`.
 628 setNgramsTableScores :: forall env err m t.
 629                         ( Each t t NgramsElement NgramsElement
 630                         , HasNodeStory env err m
 631                         , HasNodeError err
 632                         , HasConnectionPool env
 633                         , HasConfig env
 634                         , HasMail env)
 635                      => NodeId
 636                      -> ListId
 637                      -> TableNgrams.NgramsType
 638                      -> t
 639                      -> m t
 640 setNgramsTableScores nId listId ngramsType table = do
 641   t1 <- getTime
 642   occurrences <- getOccByNgramsOnlyFast nId listId ngramsType
 643   --printDebug "[setNgramsTableScores] occurrences" occurrences
 644   t2 <- getTime
 645   liftBase $ do
 646     let ngrams_terms = table ^.. each . ne_ngrams
 647     -- printDebug "ngrams_terms" ngrams_terms
 648     hprint stderr
 649       ("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n")
 650       (length ngrams_terms) t1 t2
 651   let
 652     setOcc ne = ne & ne_occurrences .~ msumOf (at (ne ^. ne_ngrams) . _Just) occurrences
 653
 654   --printDebug "[setNgramsTableScores] with occurences" $ table & each %~ setOcc
 655
 656   pure $ table & each %~ setOcc
 657
 658
 659
 660
 661 scoresRecomputeTableNgrams :: forall env err m.
 662   (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
 663   => NodeId -> TabType -> ListId -> m Int
 664 scoresRecomputeTableNgrams nId tabType listId = do
 665   tableMap <- getNgramsTableMap listId ngramsType
 666   _ <- tableMap & v_data %%~ (setNgramsTableScores nId listId ngramsType)
 667                            . Map.mapWithKey ngramsElementFromRepo
 668
 669   pure $ 1
 670   where
 671     ngramsType = ngramsTypeFromTabType tabType
 672
 673
 674 -- APIs
 675
 676 -- TODO: find a better place for the code above, All APIs stay here
 677
 678 data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
 679              deriving (Generic, Enum, Bounded, Read, Show)
 680
 681 instance FromHttpApiData OrderBy
 682   where
 683     parseUrlPiece "TermAsc"   = pure TermAsc
 684     parseUrlPiece "TermDesc"  = pure TermDesc
 685     parseUrlPiece "ScoreAsc"  = pure ScoreAsc
 686     parseUrlPiece "ScoreDesc" = pure ScoreDesc
 687     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 688
 689 instance ToHttpApiData OrderBy where
 690   toUrlPiece = pack . show
 691
 692 instance ToParamSchema OrderBy
 693 instance FromJSON  OrderBy
 694 instance ToJSON    OrderBy
 695 instance ToSchema  OrderBy
 696 instance Arbitrary OrderBy
 697   where
 698     arbitrary = elements [minBound..maxBound]
 699
 700 needsScores :: Maybe OrderBy -> Bool
 701 needsScores (Just ScoreAsc)  = True
 702 needsScores (Just ScoreDesc) = True
 703 needsScores _ = False
 704
 705 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 706                       :> QueryParamR "ngramsType"  TabType
 707                       :> QueryParamR "list"        ListId
 708                       :> QueryParamR "limit"       Limit
 709                       :> QueryParam  "offset"      Offset
 710                       :> QueryParam  "listType"    ListType
 711                       :> QueryParam  "minTermSize" MinSize
 712                       :> QueryParam  "maxTermSize" MaxSize
 713                       :> QueryParam  "orderBy"     OrderBy
 714                       :> QueryParam  "search"      Text
 715                       :> Get    '[JSON] (VersionedWithCount NgramsTable)
 716
 717 type TableNgramsApiPut = Summary " Table Ngrams API Change"
 718                        :> QueryParamR "ngramsType" TabType
 719                        :> QueryParamR "list"       ListId
 720                        :> ReqBody '[JSON] (Versioned NgramsTablePatch)
 721                        :> Put     '[JSON] (Versioned NgramsTablePatch)
 722
 723 type RecomputeScoresNgramsApiGet = Summary " Recompute scores for ngrams table"
 724                        :> QueryParamR "ngramsType"  TabType
 725                        :> QueryParamR "list"        ListId
 726                        :> "recompute" :> Post '[JSON] Int
 727
 728 type TableNgramsApiGetVersion = Summary " Table Ngrams API Get Version"
 729                       :> QueryParamR "ngramsType"  TabType
 730                       :> QueryParamR "list"        ListId
 731                       :> Get    '[JSON] Version
 732
 733 type TableNgramsApi =  TableNgramsApiGet
 734                   :<|> TableNgramsApiPut
 735                   :<|> RecomputeScoresNgramsApiGet
 736                   :<|> "version" :> TableNgramsApiGetVersion
 737                   :<|> TableNgramsAsyncApi
 738
 739 type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
 740                            :> "async"
 741                            :> "charts"
 742                            :> "update"
 743                            :> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog
 744
 745 getTableNgramsCorpus :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
 746                => NodeId
 747                -> TabType
 748                -> ListId
 749                -> Limit
 750                -> Maybe Offset
 751                -> Maybe ListType
 752                -> Maybe MinSize -> Maybe MaxSize
 753                -> Maybe OrderBy
 754                -> Maybe Text -- full text search
 755                -> m (VersionedWithCount NgramsTable)
 756 getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
 757   getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
 758     where
 759       searchQuery (NgramsTerm nt) = maybe (const True) isInfixOf mt nt
 760
 761
 762
 763 getTableNgramsVersion :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
 764                => NodeId
 765                -> TabType
 766                -> ListId
 767                -> m Version
 768 getTableNgramsVersion _nId _tabType listId = currentVersion listId
 769
 770
 771
 772   -- TODO: limit?
 773   -- Versioned { _v_version = v } <- getTableNgramsCorpus nId tabType listId 100000 Nothing Nothing Nothing Nothing Nothing Nothing
 774   -- This line above looks like a waste of computation to finally get only the version.
 775   -- See the comment about listNgramsChangedSince.
 776
 777
 778 -- | Text search is deactivated for now for ngrams by doc only
 779 getTableNgramsDoc :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env, HasMail env)
 780                => DocId -> TabType
 781                -> ListId -> Limit -> Maybe Offset
 782                -> Maybe ListType
 783                -> Maybe MinSize -> Maybe MaxSize
 784                -> Maybe OrderBy
 785                -> Maybe Text -- full text search
 786                -> m (VersionedWithCount NgramsTable)
 787 getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do
 788   ns <- selectNodesWithUsername NodeList userMaster
 789   let ngramsType = ngramsTypeFromTabType tabType
 790   ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
 791   let searchQuery (NgramsTerm nt) = flip S.member (S.fromList ngs) nt
 792   getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
 793
 794
 795
 796 apiNgramsTableCorpus :: NodeId -> ServerT TableNgramsApi (GargM Env GargError)
 797 apiNgramsTableCorpus cId =  getTableNgramsCorpus       cId
 798                        :<|> tableNgramsPut
 799                        :<|> scoresRecomputeTableNgrams cId
 800                        :<|> getTableNgramsVersion      cId
 801                        :<|> apiNgramsAsync             cId
 802
 803 apiNgramsTableDoc :: DocId -> ServerT TableNgramsApi (GargM Env GargError)
 804 apiNgramsTableDoc dId =  getTableNgramsDoc          dId
 805                     :<|> tableNgramsPut
 806                     :<|> scoresRecomputeTableNgrams dId
 807                     :<|> getTableNgramsVersion      dId
 808                     :<|> apiNgramsAsync             dId
 809
 810 apiNgramsAsync :: NodeId -> ServerT TableNgramsAsyncApi (GargM Env GargError)
 811 apiNgramsAsync _dId =
 812   serveJobsAPI TableNgramsJob $ \i log ->
 813       let
 814         log' x = do
 815           printDebug "tableNgramsPostChartsAsync" x
 816           liftBase $ log x
 817       in tableNgramsPostChartsAsync i log'
 818
 819 -- Did the given list of ngrams changed since the given version?
 820 -- The returned value is versioned boolean value, meaning that one always retrieve the
 821 -- latest version.
 822 -- If the given version is negative then one simply receive the latest version and True.
 823 -- Using this function is more precise than simply comparing the latest version number
 824 -- with the local version number. Indeed there might be no change to this particular list
 825 -- and still the version number has changed because of other lists.
 826 --
 827 -- Here the added value is to make a compromise between precision, computation, and bandwidth:
 828 -- * currentVersion: good computation, good bandwidth, bad precision.
 829 -- * listNgramsChangedSince: good precision, good bandwidth, bad computation.
 830 -- * tableNgramsPull: good precision, good bandwidth (if you use the received data!), bad computation.
 831 listNgramsChangedSince :: HasNodeStory env err m
 832                        => ListId -> TableNgrams.NgramsType -> Version -> m (Versioned Bool)
 833 listNgramsChangedSince listId ngramsType version
 834   | version < 0 =
 835       Versioned <$> currentVersion listId <*> pure True
 836   | otherwise   =
 837       tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)