src/Gargantext/API/Ngrams.hs

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