src/Gargantext/API/Ngrams.hs

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