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