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 DataKinds         #-}
  21 {-# LANGUAGE DeriveGeneric     #-}
  22 {-# LANGUAGE NoImplicitPrelude #-}
  23 {-# LANGUAGE OverloadedStrings #-}
  24 {-# LANGUAGE ScopedTypeVariables #-}
  25 {-# LANGUAGE TemplateHaskell   #-}
  26 {-# LANGUAGE TypeOperators     #-}
  27 {-# LANGUAGE FlexibleContexts  #-}
  28 {-# LANGUAGE FlexibleInstances #-}
  29 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  30 {-# LANGUAGE MultiParamTypeClasses #-}
  31 {-# LANGUAGE RankNTypes        #-}
  32 {-# LANGUAGE TypeFamilies      #-}
  33 {-# OPTIONS -fno-warn-orphans #-}
  34
  35 module Gargantext.API.Ngrams
  36   ( TableNgramsApi
  37   , TableNgramsApiGet
  38   , TableNgramsApiPut
  39   , TableNgramsApiPost
  40
  41   , getTableNgrams
  42   , putListNgrams
  43   , putListNgrams'
  44   , tableNgramsPost
  45   , apiNgramsTableCorpus
  46   , apiNgramsTableDoc
  47
  48   , NgramsStatePatch
  49   , NgramsTablePatch
  50   , NgramsTableMap
  51
  52   , NgramsElement(..)
  53   , mkNgramsElement
  54   , mergeNgramsElement
  55
  56   , RootParent(..)
  57
  58   , MSet
  59   , mSetFromList
  60   , mSetToList
  61
  62   , Repo(..)
  63   , r_version
  64   , r_state
  65   , r_history
  66   , NgramsRepo
  67   , NgramsRepoElement(..)
  68   , saveRepo
  69   , initRepo
  70
  71   , RepoEnv(..)
  72   , renv_var
  73   , renv_lock
  74
  75   , TabType(..)
  76   , ngramsTypeFromTabType
  77
  78   , HasRepoVar(..)
  79   , HasRepoSaver(..)
  80   , HasRepo(..)
  81   , RepoCmdM
  82   , QueryParamR
  83   , TODO
  84
  85   -- Internals
  86   , getNgramsTableMap
  87   , tableNgramsPull
  88   , tableNgramsPut
  89
  90   , Version
  91   , Versioned(..)
  92   , currentVersion
  93   , listNgramsChangedSince
  94   )
  95   where
  96
  97 -- import Debug.Trace (trace)
  98 import Prelude (Enum, Bounded, Semigroup(..), minBound, maxBound {-, round-}, error)
  99 -- import Gargantext.Database.Schema.User  (UserId)
 100 import Data.Patch.Class (Replace, replace, Action(act), Applicable(..),
 101                          Composable(..), Transformable(..),
 102                          PairPatch(..), Patched, ConflictResolution,
 103                          ConflictResolutionReplace, ours)
 104 import qualified Data.Map.Strict.Patch as PM
 105 import Data.Monoid
 106 import Data.Ord (Down(..))
 107 import Data.Foldable
 108 --import Data.Semigroup
 109 import Data.Set (Set)
 110 import qualified Data.Set as S
 111 import qualified Data.List as List
 112 import Data.Maybe (fromMaybe)
 113 -- import Data.Tuple.Extra (first)
 114 import qualified Data.Map.Strict as Map
 115 import Data.Map.Strict (Map)
 116 import qualified Data.Set as Set
 117 import Control.Category ((>>>))
 118 import Control.Concurrent
 119 import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, forOf_, (%%~), (?~), mapped)
 120 import Control.Monad.Error.Class (MonadError)
 121 import Control.Monad.Reader
 122 import Control.Monad.State
 123 import Data.Aeson hiding ((.=))
 124 import Data.Aeson.TH (deriveJSON)
 125 import Data.Either(Either(Left))
 126 -- import Data.Map (lookup)
 127 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 128 import Data.Swagger hiding (version, patch)
 129 import Data.Text (Text, isInfixOf, count)
 130 import Data.Validity
 131 import Formatting (hprint, int, (%))
 132 import Formatting.Clock (timeSpecs)
 133 import GHC.Generics (Generic)
 134 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 135 -- import Gargantext.Database.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
 136 import Gargantext.Database.Config (userMaster)
 137 import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlyFast')
 138 import Gargantext.Database.Schema.Ngrams (NgramsType)
 139 import Gargantext.Database.Types.Node (NodeType(..))
 140 import Gargantext.Database.Utils (fromField', HasConnection)
 141 import Gargantext.Database.Node.Select
 142 import Gargantext.Database.Ngrams
 143 --import Gargantext.Database.Lists (listsWith)
 144 import Gargantext.Database.Schema.Node (HasNodeError)
 145 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
 146 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
 147 -- import Gargantext.Database.Schema.NodeNgram hiding (Action)
 148 import Gargantext.Prelude
 149 import Gargantext.Core.Types (TODO)
 150 import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, HasInvalidError, assertValid)
 151 import Servant hiding (Patch)
 152 import System.Clock (getTime, TimeSpec, Clock(..))
 153 import System.FileLock (FileLock)
 154 import System.IO (stderr)
 155 import Test.QuickCheck (elements)
 156 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 157
 158 ------------------------------------------------------------------------
 159 --data FacetFormat = Table | Chart
 160 data TabType   = Docs   | Trash   | MoreFav | MoreTrash
 161                | Terms  | Sources | Authors | Institutes
 162                | Contacts
 163   deriving (Generic, Enum, Bounded, Show)
 164
 165 instance FromHttpApiData TabType
 166   where
 167     parseUrlPiece "Docs"       = pure Docs
 168     parseUrlPiece "Trash"      = pure Trash
 169     parseUrlPiece "MoreFav"    = pure MoreFav
 170     parseUrlPiece "MoreTrash"  = pure MoreTrash
 171
 172     parseUrlPiece "Terms"      = pure Terms
 173     parseUrlPiece "Sources"    = pure Sources
 174     parseUrlPiece "Institutes" = pure Institutes
 175     parseUrlPiece "Authors"    = pure Authors
 176
 177     parseUrlPiece "Contacts"   = pure Contacts
 178
 179     parseUrlPiece _            = Left "Unexpected value of TabType"
 180
 181 instance ToParamSchema   TabType
 182 instance ToJSON    TabType
 183 instance FromJSON  TabType
 184 instance ToSchema  TabType
 185 instance Arbitrary TabType
 186   where
 187     arbitrary = elements [minBound .. maxBound]
 188
 189 newtype MSet a = MSet (Map a ())
 190   deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
 191
 192 instance ToJSON a => ToJSON (MSet a) where
 193   toJSON     (MSet m) = toJSON     (Map.keys m)
 194   toEncoding (MSet m) = toEncoding (Map.keys m)
 195
 196 mSetFromSet :: Set a -> MSet a
 197 mSetFromSet = MSet . Map.fromSet (const ())
 198
 199 mSetFromList :: Ord a => [a] -> MSet a
 200 mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
 201
 202 -- mSetToSet :: Ord a => MSet a -> Set a
 203 -- mSetToSet (MSet a) = Set.fromList ( Map.keys a)
 204 mSetToSet :: Ord a => MSet a -> Set a
 205 mSetToSet = Set.fromList . mSetToList
 206
 207 mSetToList :: MSet a -> [a]
 208 mSetToList (MSet a) = Map.keys a
 209
 210 instance Foldable MSet where
 211   foldMap f (MSet m) = Map.foldMapWithKey (\k _ -> f k) m
 212
 213 instance (Ord a, FromJSON a) => FromJSON (MSet a) where
 214   parseJSON = fmap mSetFromList . parseJSON
 215
 216 instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
 217   -- TODO
 218   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
 219
 220 ------------------------------------------------------------------------
 221 type NgramsTerm = Text
 222
 223 data RootParent = RootParent
 224   { _rp_root   :: NgramsTerm
 225   , _rp_parent :: NgramsTerm
 226   }
 227   deriving (Ord, Eq, Show, Generic)
 228
 229 deriveJSON (unPrefix "_rp_") ''RootParent
 230 makeLenses ''RootParent
 231
 232 data NgramsRepoElement = NgramsRepoElement
 233   { _nre_size        :: Int
 234   , _nre_list        :: ListType
 235 --, _nre_root_parent :: Maybe RootParent
 236   , _nre_root        :: Maybe NgramsTerm
 237   , _nre_parent      :: Maybe NgramsTerm
 238   , _nre_children    :: MSet NgramsTerm
 239   }
 240   deriving (Ord, Eq, Show, Generic)
 241
 242 deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
 243 makeLenses ''NgramsRepoElement
 244
 245 instance ToSchema NgramsRepoElement where
 246   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
 247
 248
 249 data NgramsElement =
 250      NgramsElement { _ne_ngrams      :: NgramsTerm
 251                    , _ne_size        :: Int
 252                    , _ne_list        :: ListType
 253                    , _ne_occurrences :: Int
 254                    , _ne_root        :: Maybe NgramsTerm
 255                    , _ne_parent      :: Maybe NgramsTerm
 256                    , _ne_children    :: MSet  NgramsTerm
 257                    }
 258       deriving (Ord, Eq, Show, Generic)
 259
 260 deriveJSON (unPrefix "_ne_") ''NgramsElement
 261 makeLenses ''NgramsElement
 262
 263 mkNgramsElement :: NgramsTerm
 264                 -> ListType
 265                 -> Maybe RootParent
 266                 -> MSet NgramsTerm
 267                 -> NgramsElement
 268 mkNgramsElement ngrams list rp children =
 269   NgramsElement ngrams size list 1 (_rp_root <$> rp) (_rp_parent <$> rp) children
 270   where
 271     -- TODO review
 272     size = 1 + count " " ngrams
 273
 274 newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement
 275 newNgramsElement mayList ngrams =
 276   mkNgramsElement ngrams (fromMaybe GraphTerm mayList) Nothing mempty
 277
 278 instance ToSchema NgramsElement where
 279   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
 280 instance Arbitrary NgramsElement where
 281   arbitrary = elements [newNgramsElement Nothing "sport"]
 282
 283 ngramsElementToRepo :: NgramsElement -> NgramsRepoElement
 284 ngramsElementToRepo
 285   (NgramsElement { _ne_size     = s
 286                  , _ne_list     = l
 287                  , _ne_root     = r
 288                  , _ne_parent   = p
 289                  , _ne_children = c
 290                  }) =
 291   NgramsRepoElement
 292     { _nre_size     = s
 293     , _nre_list     = l
 294     , _nre_parent   = p
 295     , _nre_root     = r
 296     , _nre_children = c
 297     }
 298
 299 ngramsElementFromRepo :: NgramsTerm -> NgramsRepoElement -> NgramsElement
 300 ngramsElementFromRepo
 301   ngrams
 302   (NgramsRepoElement
 303       { _nre_size     = s
 304       , _nre_list     = l
 305       , _nre_parent   = p
 306       , _nre_root     = r
 307       , _nre_children = c
 308       }) =
 309   NgramsElement { _ne_size        = s
 310                 , _ne_list        = l
 311                 , _ne_root        = r
 312                 , _ne_parent      = p
 313                 , _ne_children    = c
 314                 , _ne_ngrams      = ngrams
 315                 , _ne_occurrences = panic $ "API.Ngrams._ne_occurrences"
 316                 {-
 317                 -- Here we could use 0 if we want to avoid any `panic`.
 318                 -- It will not happen using getTableNgrams if
 319                 -- getOccByNgramsOnly provides a count of occurrences for
 320                 -- all the ngrams given.
 321                 -}
 322                 }
 323
 324 ------------------------------------------------------------------------
 325 newtype NgramsTable = NgramsTable [NgramsElement]
 326   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 327
 328 type NgramsList = NgramsTable
 329
 330 makePrisms ''NgramsTable
 331
 332 -- | Question: why these repetition of Type in this instance
 333 -- may you document it please ?
 334 instance Each NgramsTable NgramsTable NgramsElement NgramsElement where
 335   each = _NgramsTable . each
 336
 337 -- TODO discuss
 338 -- | TODO Check N and Weight
 339 {-
 340 toNgramsElement :: [NgramsTableData] -> [NgramsElement]
 341 toNgramsElement ns = map toNgramsElement' ns
 342     where
 343       toNgramsElement' (NgramsTableData _ p t _ lt w) = NgramsElement t lt' (round w) p' c'
 344         where
 345           p' = case p of
 346                  Nothing -> Nothing
 347                  Just x  -> lookup x mapParent
 348           c' = maybe mempty identity $ lookup t mapChildren
 349           lt' = maybe (panic "API.Ngrams: listypeId") identity lt
 350
 351       mapParent :: Map Int Text
 352       mapParent   = Map.fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
 353
 354       mapChildren :: Map Text (Set Text)
 355       mapChildren = Map.mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
 356                   $ Map.fromListWith (<>)
 357                   $ map (first fromJust)
 358                   $ filter (isJust . fst)
 359                   $ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
 360 -}
 361
 362 mockTable :: NgramsTable
 363 mockTable = NgramsTable
 364   [ mkNgramsElement "animal"  GraphTerm      Nothing       (mSetFromList ["dog", "cat"])
 365   , mkNgramsElement "cat"     GraphTerm     (rp "animal")  mempty
 366   , mkNgramsElement "cats"    StopTerm       Nothing       mempty
 367   , mkNgramsElement "dog"     GraphTerm     (rp "animal")  (mSetFromList ["dogs"])
 368   , mkNgramsElement "dogs"    StopTerm      (rp "dog")     mempty
 369   , mkNgramsElement "fox"     GraphTerm      Nothing       mempty
 370   , mkNgramsElement "object"  CandidateTerm  Nothing       mempty
 371   , mkNgramsElement "nothing" StopTerm       Nothing       mempty
 372   , mkNgramsElement "organic" GraphTerm      Nothing       (mSetFromList ["flower"])
 373   , mkNgramsElement "flower"  GraphTerm     (rp "organic") mempty
 374   , mkNgramsElement "moon"    CandidateTerm  Nothing       mempty
 375   , mkNgramsElement "sky"     StopTerm       Nothing       mempty
 376   ]
 377   where
 378     rp n = Just $ RootParent n n
 379
 380 instance Arbitrary NgramsTable where
 381   arbitrary = pure mockTable
 382
 383 instance ToSchema NgramsTable
 384
 385 ------------------------------------------------------------------------
 386 type NgramsTableMap = Map NgramsTerm NgramsRepoElement
 387 ------------------------------------------------------------------------
 388 -- On the Client side:
 389 --data Action = InGroup     NgramsId NgramsId
 390 --            | OutGroup    NgramsId NgramsId
 391 --            | SetListType NgramsId ListType
 392
 393 data PatchSet a = PatchSet
 394   { _rem :: Set a
 395   , _add :: Set a
 396   }
 397   deriving (Eq, Ord, Show, Generic)
 398
 399 makeLenses ''PatchSet
 400 makePrisms ''PatchSet
 401
 402 instance ToJSON a => ToJSON (PatchSet a) where
 403   toJSON     = genericToJSON     $ unPrefix "_"
 404   toEncoding = genericToEncoding $ unPrefix "_"
 405
 406 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
 407   parseJSON = genericParseJSON $ unPrefix "_"
 408
 409 {-
 410 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
 411   arbitrary = PatchSet <$> arbitrary <*> arbitrary
 412
 413 type instance Patched (PatchSet a) = Set a
 414
 415 type ConflictResolutionPatchSet a = SimpleConflictResolution' (Set a)
 416 type instance ConflictResolution (PatchSet a) = ConflictResolutionPatchSet a
 417
 418 instance Ord a => Semigroup (PatchSet a) where
 419   p <> q = PatchSet { _rem = (q ^. rem) `Set.difference` (p ^. add) <> p ^. rem
 420                     , _add = (q ^. add) `Set.difference` (p ^. rem) <> p ^. add
 421                     } -- TODO Review
 422
 423 instance Ord a => Monoid (PatchSet a) where
 424   mempty = PatchSet mempty mempty
 425
 426 instance Ord a => Group (PatchSet a) where
 427   invert (PatchSet r a) = PatchSet a r
 428
 429 instance Ord a => Composable (PatchSet a) where
 430   composable _ _ = undefined
 431
 432 instance Ord a => Action (PatchSet a) (Set a) where
 433   act p source = (source `Set.difference` (p ^. rem)) <> p ^. add
 434
 435 instance Applicable (PatchSet a) (Set a) where
 436   applicable _ _ = mempty
 437
 438 instance Ord a => Validity (PatchSet a) where
 439   validate p = check (Set.disjoint (p ^. rem) (p ^. add)) "_rem and _add should be dijoint"
 440
 441 instance Ord a => Transformable (PatchSet a) where
 442   transformable = undefined
 443
 444   conflicts _p _q = undefined
 445
 446   transformWith conflict p q = undefined conflict p q
 447
 448 instance ToSchema a => ToSchema (PatchSet a)
 449 -}
 450
 451 type AddRem = Replace (Maybe ())
 452
 453 remPatch, addPatch :: AddRem
 454 remPatch = replace (Just ()) Nothing
 455 addPatch = replace Nothing (Just ())
 456
 457 isRem :: Replace (Maybe ()) -> Bool
 458 isRem = (== remPatch)
 459
 460 type PatchMap = PM.PatchMap
 461
 462 newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
 463   deriving (Eq, Show, Generic, Validity, Semigroup, Monoid,
 464             Transformable, Composable)
 465
 466 type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
 467 type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
 468
 469 -- TODO this breaks module abstraction
 470 makePrisms ''PM.PatchMap
 471
 472 makePrisms ''PatchMSet
 473
 474 _PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
 475 _PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
 476   where
 477     f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
 478     f = Map.partition isRem >>> both %~ Map.keysSet
 479
 480     g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
 481     g (rems, adds) = Map.fromSet (const remPatch) rems
 482                   <> Map.fromSet (const addPatch) adds
 483
 484 instance Ord a => Action (PatchMSet a) (MSet a) where
 485   act (PatchMSet p) (MSet m) = MSet $ act p m
 486
 487 instance Ord a => Applicable (PatchMSet a) (MSet a) where
 488   applicable (PatchMSet p) (MSet m) = applicable p m
 489
 490 instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
 491   toJSON     = toJSON . view _PatchMSetIso
 492   toEncoding = toEncoding . view _PatchMSetIso
 493
 494 instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
 495   parseJSON = fmap (_PatchMSetIso #) . parseJSON
 496
 497 instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
 498   arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
 499
 500 instance ToSchema a => ToSchema (PatchMSet a) where
 501   -- TODO
 502   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
 503
 504 type instance Patched (PatchMSet a) = MSet a
 505
 506 instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
 507   arbitrary = uncurry replace <$> arbitrary
 508     -- If they happen to be equal then the patch is Keep.
 509
 510 instance ToSchema a => ToSchema (Replace a) where
 511   declareNamedSchema (_ :: Proxy (Replace a)) = do
 512     -- TODO Keep constructor is not supported here.
 513     aSchema <- declareSchemaRef (Proxy :: Proxy a)
 514     return $ NamedSchema (Just "Replace") $ mempty
 515       & type_ ?~ SwaggerObject
 516       & properties .~
 517           InsOrdHashMap.fromList
 518           [ ("old", aSchema)
 519           , ("new", aSchema)
 520           ]
 521       & required .~ [ "old", "new" ]
 522
 523 data NgramsPatch =
 524      NgramsPatch { _patch_children :: PatchMSet NgramsTerm
 525                  , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
 526                  }
 527       deriving (Eq, Show, Generic)
 528
 529 deriveJSON (unPrefix "_") ''NgramsPatch
 530 makeLenses ''NgramsPatch
 531
 532 instance ToSchema  NgramsPatch where
 533   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
 534
 535 instance Arbitrary NgramsPatch where
 536   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 537
 538 type NgramsPatchIso = PairPatch (PatchMSet NgramsTerm) (Replace ListType)
 539
 540 _NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
 541 _NgramsPatch = iso (\(NgramsPatch c l) -> c :*: l) (\(c :*: l) -> NgramsPatch c l)
 542
 543 instance Semigroup NgramsPatch where
 544   p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
 545
 546 instance Monoid NgramsPatch where
 547   mempty = _NgramsPatch # mempty
 548
 549 instance Validity NgramsPatch where
 550   validate p = p ^. _NgramsPatch . to validate
 551
 552 instance Transformable NgramsPatch where
 553   transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 554
 555   conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 556
 557   transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
 558     where
 559       (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 560
 561 type ConflictResolutionNgramsPatch =
 562   ( ConflictResolutionPatchMSet NgramsTerm
 563   , ConflictResolutionReplace ListType
 564   )
 565 type instance ConflictResolution NgramsPatch =
 566   ConflictResolutionNgramsPatch
 567
 568 type PatchedNgramsPatch = (Set NgramsTerm, ListType)
 569   -- ~ Patched NgramsPatchIso
 570 type instance Patched NgramsPatch = PatchedNgramsPatch
 571
 572 instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
 573   applicable p Nothing   = check (p == mempty) "NgramsPatch should be empty here"
 574   applicable p (Just nre) =
 575     applicable (p ^. patch_children) (nre ^. nre_children) <>
 576     applicable (p ^. patch_list)     (nre ^. nre_list)
 577
 578 instance Action NgramsPatch NgramsRepoElement where
 579   act p = (nre_children %~ act (p ^. patch_children))
 580         . (nre_list     %~ act (p ^. patch_list))
 581
 582 instance Action NgramsPatch (Maybe NgramsRepoElement) where
 583   act = fmap . act
 584
 585 newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
 586   deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
 587
 588 instance FromField NgramsTablePatch
 589   where
 590     fromField = fromField'
 591
 592 instance FromField (PatchMap NgramsType (PatchMap NodeId NgramsTablePatch))
 593   where
 594     fromField = fromField'
 595
 596 --instance (Ord k, Action pv (Maybe v)) => Action (PatchMap k pv) (Map k v) where
 597 --
 598 type instance ConflictResolution NgramsTablePatch =
 599   NgramsTerm -> ConflictResolutionNgramsPatch
 600
 601 type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
 602   -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
 603 type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
 604
 605 makePrisms ''NgramsTablePatch
 606 instance ToSchema  (PatchMap NgramsTerm NgramsPatch)
 607 instance ToSchema  NgramsTablePatch
 608
 609 instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
 610   applicable p = applicable (p ^. _NgramsTablePatch)
 611
 612 instance Action NgramsTablePatch (Maybe NgramsTableMap) where
 613   act p =
 614     fmap (execState (reParentNgramsTablePatch p)) .
 615     act (p ^. _NgramsTablePatch)
 616
 617 instance Arbitrary NgramsTablePatch where
 618   arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
 619
 620 -- Should it be less than an Lens' to preserve PatchMap's abstraction.
 621 -- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
 622 -- ntp_ngrams_patches = _NgramsTablePatch .  undefined
 623
 624 type ReParent a = forall m. MonadState NgramsTableMap m => a -> m ()
 625
 626 reRootChildren :: NgramsTerm -> ReParent NgramsTerm
 627 reRootChildren root ngram = do
 628   nre <- use $ at ngram
 629   forOf_ (_Just . nre_children . folded) nre $ \child -> do
 630     at child . _Just . nre_root ?= root
 631     reRootChildren root child
 632
 633 reParent :: Maybe RootParent -> ReParent NgramsTerm
 634 reParent rp child = do
 635   at child . _Just %= ( (nre_parent .~ (_rp_parent <$> rp))
 636                       . (nre_root   .~ (_rp_root   <$> rp))
 637                       )
 638   reRootChildren (fromMaybe child (rp ^? _Just . rp_root)) child
 639
 640 reParentAddRem :: RootParent -> NgramsTerm -> ReParent AddRem
 641 reParentAddRem rp child p =
 642   reParent (if isRem p then Nothing else Just rp) child
 643
 644 reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
 645 reParentNgramsPatch parent ngramsPatch = do
 646   root_of_parent <- use (at parent . _Just . nre_root)
 647   let
 648     root = fromMaybe parent root_of_parent
 649     rp   = RootParent { _rp_root = root, _rp_parent = parent }
 650   itraverse_ (reParentAddRem rp) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap)
 651   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 652
 653 reParentNgramsTablePatch :: ReParent NgramsTablePatch
 654 reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
 655   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 656
 657 ------------------------------------------------------------------------
 658 ------------------------------------------------------------------------
 659 type Version = Int
 660
 661 data Versioned a = Versioned
 662   { _v_version :: Version
 663   , _v_data    :: a
 664   }
 665   deriving (Generic, Show)
 666 deriveJSON (unPrefix "_v_") ''Versioned
 667 makeLenses ''Versioned
 668 instance ToSchema a => ToSchema (Versioned a) where
 669   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_v_")
 670 instance Arbitrary a => Arbitrary (Versioned a) where
 671   arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 672
 673 {-
 674 -- TODO sequencs of modifications (Patchs)
 675 type NgramsIdPatch = Patch NgramsId NgramsPatch
 676
 677 ngramsPatch :: Int -> NgramsPatch
 678 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopTerm)]) (Set.fromList [n]) Set.empty
 679
 680 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 681 toEdit n p = Edit n p
 682 ngramsIdPatch :: Patch NgramsId NgramsPatch
 683 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 684                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 685                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 686                                        ]
 687
 688 -- applyPatchBack :: Patch -> IO Patch
 689 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 690 -}
 691 ------------------------------------------------------------------------
 692 ------------------------------------------------------------------------
 693 ------------------------------------------------------------------------
 694
 695 {-
 696 -- TODO: Replace.old is ignored which means that if the current list
 697 -- `GraphTerm` and that the patch is `Replace CandidateTerm StopTerm` then
 698 -- the list is going to be `StopTerm` while it should keep `GraphTerm`.
 699 -- However this should not happen in non conflicting situations.
 700 mkListsUpdate :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)]
 701 mkListsUpdate nt patches =
 702   [ (ngramsTypeId nt, ng, listTypeId lt)
 703   | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 704   , lt <- patch ^.. patch_list . new
 705   ]
 706
 707 mkChildrenGroups :: (PatchSet NgramsTerm -> Set NgramsTerm)
 708                  -> NgramsType
 709                  -> NgramsTablePatch
 710                  -> [(NgramsTypeId, NgramsParent, NgramsChild)]
 711 mkChildrenGroups addOrRem nt patches =
 712   [ (ngramsTypeId nt, parent, child)
 713   | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 714   , child <- patch ^.. patch_children . to addOrRem . folded
 715   ]
 716 -}
 717
 718 ngramsTypeFromTabType :: TabType -> NgramsType
 719 ngramsTypeFromTabType tabType =
 720   let lieu = "Garg.API.Ngrams: " :: Text in
 721     case tabType of
 722       Sources    -> Ngrams.Sources
 723       Authors    -> Ngrams.Authors
 724       Institutes -> Ngrams.Institutes
 725       Terms      -> Ngrams.NgramsTerms
 726       _          -> panic $ lieu <> "No Ngrams for this tab"
 727       -- TODO: This `panic` would disapear with custom NgramsType.
 728
 729 ------------------------------------------------------------------------
 730 data Repo s p = Repo
 731   { _r_version :: Version
 732   , _r_state   :: s
 733   , _r_history :: [p]
 734     -- first patch in the list is the most recent
 735   }
 736   deriving (Generic)
 737
 738 instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
 739   parseJSON = genericParseJSON $ unPrefix "_r_"
 740
 741 instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
 742   toJSON     = genericToJSON     $ unPrefix "_r_"
 743   toEncoding = genericToEncoding $ unPrefix "_r_"
 744
 745 makeLenses ''Repo
 746
 747 initRepo :: Monoid s => Repo s p
 748 initRepo = Repo 1 mempty []
 749
 750 type NgramsRepo       = Repo NgramsState NgramsStatePatch
 751 type NgramsState      = Map NgramsType (Map NodeId NgramsTableMap)
 752 type NgramsStatePatch = PatchMap NgramsType (PatchMap NodeId NgramsTablePatch)
 753
 754 initMockRepo :: NgramsRepo
 755 initMockRepo = Repo 1 s []
 756   where
 757     s = Map.singleton Ngrams.NgramsTerms
 758       $ Map.singleton 47254
 759       $ Map.fromList
 760       [ (n ^. ne_ngrams, ngramsElementToRepo n) | n <- mockTable ^. _NgramsTable ]
 761
 762 data RepoEnv = RepoEnv
 763   { _renv_var   :: !(MVar NgramsRepo)
 764   , _renv_saver :: !(IO ())
 765   , _renv_lock  :: !FileLock
 766   }
 767   deriving (Generic)
 768
 769 makeLenses ''RepoEnv
 770
 771 class HasRepoVar env where
 772   repoVar :: Getter env (MVar NgramsRepo)
 773
 774 instance HasRepoVar (MVar NgramsRepo) where
 775   repoVar = identity
 776
 777 class HasRepoSaver env where
 778   repoSaver :: Getter env (IO ())
 779
 780 class (HasRepoVar env, HasRepoSaver env) => HasRepo env where
 781   repoEnv :: Getter env RepoEnv
 782
 783 instance HasRepo RepoEnv where
 784   repoEnv = identity
 785
 786 instance HasRepoVar RepoEnv where
 787   repoVar = renv_var
 788
 789 instance HasRepoSaver RepoEnv where
 790   repoSaver = renv_saver
 791
 792 type RepoCmdM   env err m =
 793   ( MonadReader env     m
 794   , MonadError      err m
 795   , MonadIO             m
 796   , HasRepo     env
 797   )
 798 ------------------------------------------------------------------------
 799
 800 saveRepo :: ( MonadReader env m, MonadIO m, HasRepoSaver env )
 801          => m ()
 802 saveRepo = liftIO =<< view repoSaver
 803
 804 listTypeConflictResolution :: ListType -> ListType -> ListType
 805 listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
 806
 807 ngramsStatePatchConflictResolution
 808   :: NgramsType -> NodeId -> NgramsTerm
 809   -> ConflictResolutionNgramsPatch
 810 ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
 811   = (const ours, ours)
 812   -- undefined {- TODO think this through -}, listTypeConflictResolution)
 813
 814 -- Current state:
 815 --   Insertions are not considered as patches,
 816 --   they do not extend history,
 817 --   they do not bump version.
 818 insertNewOnly :: a -> Maybe b -> a
 819 insertNewOnly m = maybe m (const $ error "insertNewOnly: impossible")
 820   -- TODO error handling
 821
 822 something :: Monoid a => Maybe a -> a
 823 something Nothing  = mempty
 824 something (Just a) = a
 825
 826 {- unused
 827 -- TODO refactor with putListNgrams
 828 copyListNgrams :: RepoCmdM env err m
 829                => NodeId -> NodeId -> NgramsType
 830                -> m ()
 831 copyListNgrams srcListId dstListId ngramsType = do
 832   var <- view repoVar
 833   liftIO $ modifyMVar_ var $
 834     pure . (r_state . at ngramsType %~ (Just . f . something))
 835   saveRepo
 836   where
 837     f :: Map NodeId NgramsTableMap -> Map NodeId NgramsTableMap
 838     f m = m & at dstListId %~ insertNewOnly (m ^. at srcListId)
 839
 840 -- TODO refactor with putListNgrams
 841 -- The list must be non-empty!
 842 -- The added ngrams must be non-existent!
 843 addListNgrams :: RepoCmdM env err m
 844               => NodeId -> NgramsType
 845               -> [NgramsElement] -> m ()
 846 addListNgrams listId ngramsType nes = do
 847   var <- view repoVar
 848   liftIO $ modifyMVar_ var $
 849     pure . (r_state . at ngramsType . _Just . at listId . _Just <>~ m)
 850   saveRepo
 851   where
 852     m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
 853 -}
 854
 855 -- If the given list of ngrams elements contains ngrams already in
 856 -- the repo, they will be ignored.
 857 putListNgrams :: RepoCmdM env err m
 858               => NodeId -> NgramsType
 859               -> [NgramsElement] -> m ()
 860 putListNgrams _ _ [] = pure ()
 861 putListNgrams listId ngramsType nes = putListNgrams' listId ngramsType m
 862   where
 863     m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
 864
 865 putListNgrams' :: RepoCmdM env err m
 866                => ListId -> NgramsType
 867                -> Map NgramsTerm NgramsRepoElement
 868                -> m ()
 869 putListNgrams' listId ngramsType ns = do
 870   -- printDebug "putListNgrams" (length nes)
 871   var <- view repoVar
 872   liftIO $ modifyMVar_ var $
 873     pure . ( r_state
 874            . at ngramsType %~
 875              (Just .
 876                (at listId %~
 877                  ( Just
 878                  . (<> ns)
 879                  . something
 880                  )
 881                )
 882                . something
 883              )
 884            )
 885   saveRepo
 886
 887
 888 -- TODO-ACCESS check
 889 tableNgramsPost :: RepoCmdM env err m
 890                 => TabType
 891                 -> NodeId
 892                 -> Maybe ListType
 893                 -> [NgramsTerm] -> m ()
 894 tableNgramsPost tabType listId mayList =
 895   putListNgrams listId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
 896
 897 currentVersion :: RepoCmdM env err m
 898                => m Version
 899 currentVersion = do
 900   var <- view repoVar
 901   r   <- liftIO $ readMVar var
 902   pure $ r ^. r_version
 903
 904 tableNgramsPull :: RepoCmdM env err m
 905                 => ListId -> NgramsType
 906                 -> Version
 907                 -> m (Versioned NgramsTablePatch)
 908 tableNgramsPull listId ngramsType p_version = do
 909   var <- view repoVar
 910   r <- liftIO $ readMVar var
 911
 912   let
 913     q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
 914     q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
 915
 916   pure (Versioned (r ^. r_version) q_table)
 917
 918 -- Apply the given patch to the DB and returns the patch to be applied on the
 919 -- client.
 920 -- TODO-ACCESS check
 921 tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
 922                  => TabType -> ListId
 923                  -> Versioned NgramsTablePatch
 924                  -> m (Versioned NgramsTablePatch)
 925 tableNgramsPut tabType listId (Versioned p_version p_table)
 926   | p_table == mempty = do
 927       let ngramsType        = ngramsTypeFromTabType tabType
 928       tableNgramsPull listId ngramsType p_version
 929
 930   | otherwise         = do
 931       let ngramsType        = ngramsTypeFromTabType tabType
 932           (p0, p0_validity) = PM.singleton listId p_table
 933           (p, p_validity)   = PM.singleton ngramsType p0
 934
 935       assertValid p0_validity
 936       assertValid p_validity
 937
 938       var <- view repoVar
 939       vq' <- liftIO $ modifyMVar var $ \r -> do
 940         let
 941           q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
 942           (p', q') = transformWith ngramsStatePatchConflictResolution p q
 943           r' = r & r_version +~ 1
 944                 & r_state   %~ act p'
 945                 & r_history %~ (p' :)
 946           q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
 947         {-
 948         -- Ideally we would like to check these properties. However:
 949         -- * They should be checked only to debug the code. The client data
 950         --   should be able to trigger these.
 951         -- * What kind of error should they throw (we are in IO here)?
 952         -- * Should we keep modifyMVar?
 953         -- * Should we throw the validation in an Exception, catch it around
 954         --   modifyMVar and throw it back as an Error?
 955         assertValid $ transformable p q
 956         assertValid $ applicable p' (r ^. r_state)
 957         -}
 958         pure (r', Versioned (r' ^. r_version) q'_table)
 959
 960       saveRepo
 961       pure vq'
 962
 963 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
 964 mergeNgramsElement _neOld neNew = neNew
 965   {-
 966   { _ne_list        :: ListType
 967   If we merge the parents/children we can potentially create cycles!
 968   , _ne_parent      :: Maybe NgramsTerm
 969   , _ne_children    :: MSet NgramsTerm
 970   }
 971   -}
 972
 973 getNgramsTableMap :: RepoCmdM env err m
 974                   => ListId
 975                   -> NgramsType
 976                   -> m (Versioned NgramsTableMap)
 977 getNgramsTableMap nodeId ngramsType = do
 978   v    <- view repoVar
 979   repo <- liftIO $ readMVar v
 980   pure $ Versioned (repo ^. r_version)
 981                    (repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
 982
 983 type MinSize = Int
 984 type MaxSize = Int
 985
 986 -- | TODO Errors management
 987 --  TODO: polymorphic for Annuaire or Corpus or ...
 988 -- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
 989 -- TODO: should take only one ListId
 990
 991 getTime' :: MonadIO m => m TimeSpec
 992 getTime' = liftIO $ getTime ProcessCPUTime
 993
 994
 995 getTableNgrams :: forall env err m.
 996                   (RepoCmdM env err m, HasNodeError err, HasConnection env)
 997                => NodeType -> NodeId -> TabType
 998                -> ListId -> Limit -> Maybe Offset
 999                -> Maybe ListType
1000                -> Maybe MinSize -> Maybe MaxSize
1001                -> Maybe OrderBy
1002                -> (NgramsTerm -> Bool)
1003                -> m (Versioned NgramsTable)
1004 getTableNgrams _nType nId tabType listId limit_ offset
1005                listType minSize maxSize orderBy searchQuery = do
1006
1007   t0 <- getTime'
1008   -- lIds <- selectNodesWithUsername NodeList userMaster
1009   let
1010     ngramsType = ngramsTypeFromTabType tabType
1011     offset'  = maybe 0 identity offset
1012     listType' = maybe (const True) (==) listType
1013     minSize'  = maybe (const True) (<=) minSize
1014     maxSize'  = maybe (const True) (>=) maxSize
1015
1016     selected_node n = minSize'     s
1017                    && maxSize'     s
1018                    && searchQuery  (n ^. ne_ngrams)
1019                    && listType'    (n ^. ne_list)
1020       where
1021         s = n ^. ne_size
1022
1023     selected_inner roots n = maybe False (`Set.member` roots) (n ^. ne_root)
1024
1025     ---------------------------------------
1026     sortOnOrder Nothing = identity
1027     sortOnOrder (Just TermAsc)   = List.sortOn $ view ne_ngrams
1028     sortOnOrder (Just TermDesc)  = List.sortOn $ Down . view ne_ngrams
1029     sortOnOrder (Just ScoreAsc)  = List.sortOn $ view ne_occurrences
1030     sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view ne_occurrences
1031
1032     ---------------------------------------
1033     selectAndPaginate :: Map NgramsTerm NgramsElement -> [NgramsElement]
1034     selectAndPaginate tableMap = roots <> inners
1035       where
1036         list = tableMap ^.. each
1037         rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root") (tableMap ^. at r))
1038                              (ne ^. ne_root)
1039         selected_nodes = list & take limit_
1040                               . drop offset'
1041                               . filter selected_node
1042                               . sortOnOrder orderBy
1043         roots = rootOf <$> selected_nodes
1044         rootsSet = Set.fromList (_ne_ngrams <$> roots)
1045         inners = list & filter (selected_inner rootsSet)
1046
1047     ---------------------------------------
1048     setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
1049     setScores False table = pure table
1050     setScores True  table = do
1051       let ngrams_terms = (table ^.. each . ne_ngrams)
1052       t1 <- getTime'
1053       occurrences <- getOccByNgramsOnlyFast' nId
1054                                              listId
1055                                             ngramsType
1056                                             ngrams_terms
1057       t2 <- getTime'
1058       liftIO $ hprint stderr
1059         ("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
1060         (length ngrams_terms) t1 t2
1061       {-
1062       occurrences <- getOccByNgramsOnlySlow nType nId
1063                                             (lIds <> [listId])
1064                                             ngramsType
1065                                             ngrams_terms
1066       -}
1067       let
1068         setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
1069
1070       pure $ table & each %~ setOcc
1071     ---------------------------------------
1072
1073   -- lists <- catMaybes <$> listsWith userMaster
1074   -- trace (show lists) $
1075   -- getNgramsTableMap ({-lists <>-} listIds) ngramsType
1076
1077   let scoresNeeded = needsScores orderBy
1078   tableMap1 <- getNgramsTableMap listId ngramsType
1079   t1 <- getTime'
1080   tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
1081                                     . Map.mapWithKey ngramsElementFromRepo
1082   t2 <- getTime'
1083   tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
1084                                     . setScores (not scoresNeeded)
1085                                     . selectAndPaginate
1086   t3 <- getTime'
1087   liftIO $ hprint stderr
1088             ("getTableNgrams total=" % timeSpecs
1089                           % " map1=" % timeSpecs
1090                           % " map2=" % timeSpecs
1091                           % " map3=" % timeSpecs
1092                           % " sql="  % (if scoresNeeded then "map2" else "map3")
1093                           % "\n"
1094             ) t0 t3 t0 t1 t1 t2 t2 t3
1095   pure tableMap3
1096
1097
1098 -- APIs
1099
1100 -- TODO: find a better place for the code above, All APIs stay here
1101 type QueryParamR = QueryParam' '[Required, Strict]
1102
1103
1104 data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
1105              deriving (Generic, Enum, Bounded, Read, Show)
1106
1107 instance FromHttpApiData OrderBy
1108   where
1109     parseUrlPiece "TermAsc"   = pure TermAsc
1110     parseUrlPiece "TermDesc"  = pure TermDesc
1111     parseUrlPiece "ScoreAsc"  = pure ScoreAsc
1112     parseUrlPiece "ScoreDesc" = pure ScoreDesc
1113     parseUrlPiece _           = Left "Unexpected value of OrderBy"
1114
1115 instance ToParamSchema OrderBy
1116 instance FromJSON  OrderBy
1117 instance ToJSON    OrderBy
1118 instance ToSchema  OrderBy
1119 instance Arbitrary OrderBy
1120   where
1121     arbitrary = elements [minBound..maxBound]
1122
1123 needsScores :: Maybe OrderBy -> Bool
1124 needsScores (Just ScoreAsc)  = True
1125 needsScores (Just ScoreDesc) = True
1126 needsScores _ = False
1127
1128 type TableNgramsApiGet = Summary " Table Ngrams API Get"
1129                       :> QueryParamR "ngramsType"  TabType
1130                       :> QueryParamR "list"        ListId
1131                       :> QueryParamR "limit"       Limit
1132                       :> QueryParam  "offset"      Offset
1133                       :> QueryParam  "listType"    ListType
1134                       :> QueryParam  "minTermSize" MinSize
1135                       :> QueryParam  "maxTermSize" MaxSize
1136                       :> QueryParam  "orderBy"     OrderBy
1137                       :> QueryParam  "search"      Text
1138                       :> Get    '[JSON] (Versioned NgramsTable)
1139
1140 type TableNgramsApiPut = Summary " Table Ngrams API Change"
1141                        :> QueryParamR "ngramsType" TabType
1142                        :> QueryParamR "list"       ListId
1143                        :> ReqBody '[JSON] (Versioned NgramsTablePatch)
1144                        :> Put     '[JSON] (Versioned NgramsTablePatch)
1145
1146 type TableNgramsApiPost = Summary " Table Ngrams API Adds new ngrams"
1147                        :> QueryParamR "ngramsType" TabType
1148                        :> QueryParamR "list"       ListId
1149                        :> QueryParam  "listType"   ListType
1150                        :> ReqBody '[JSON] [NgramsTerm]
1151                        :> Post    '[JSON] ()
1152
1153 type TableNgramsApi =  TableNgramsApiGet
1154                   :<|> TableNgramsApiPut
1155                   :<|> TableNgramsApiPost
1156
1157 getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
1158                => NodeId -> TabType
1159                -> ListId -> Limit -> Maybe Offset
1160                -> Maybe ListType
1161                -> Maybe MinSize -> Maybe MaxSize
1162                -> Maybe OrderBy
1163                -> Maybe Text -- full text search
1164                -> m (Versioned NgramsTable)
1165 getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
1166   getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
1167     where
1168       searchQuery = maybe (const True) isInfixOf mt
1169
1170 -- | Text search is deactivated for now for ngrams by doc only
1171 getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
1172                => DocId -> TabType
1173                -> ListId -> Limit -> Maybe Offset
1174                -> Maybe ListType
1175                -> Maybe MinSize -> Maybe MaxSize
1176                -> Maybe OrderBy
1177                -> Maybe Text -- full text search
1178                -> m (Versioned NgramsTable)
1179 getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do
1180   ns <- selectNodesWithUsername NodeList userMaster
1181   let ngramsType = ngramsTypeFromTabType tabType
1182   ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
1183   let searchQuery = flip S.member (S.fromList ngs)
1184   getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
1185
1186
1187
1188 apiNgramsTableCorpus :: ( RepoCmdM env err m
1189                         , HasNodeError err
1190                         , HasInvalidError err
1191                         , HasConnection env
1192                         )
1193                      => NodeId -> ServerT TableNgramsApi m
1194 apiNgramsTableCorpus cId =  getTableNgramsCorpus cId
1195                        :<|> tableNgramsPut
1196                        :<|> tableNgramsPost
1197
1198
1199 apiNgramsTableDoc :: ( RepoCmdM env err m
1200                      , HasNodeError err
1201                      , HasInvalidError err
1202                      , HasConnection env
1203                      )
1204                   => DocId -> ServerT TableNgramsApi m
1205 apiNgramsTableDoc dId =  getTableNgramsDoc dId
1206                     :<|> tableNgramsPut
1207                     :<|> tableNgramsPost
1208                         -- > add new ngrams in database (TODO AD)
1209                         -- > index all the corpus accordingly (TODO AD)
1210
1211 listNgramsChangedSince :: RepoCmdM env err m
1212                        => ListId -> NgramsType -> Version -> m (Versioned Bool)
1213 listNgramsChangedSince listId ngramsType version
1214   | version < 0 =
1215       Versioned <$> currentVersion <*> pure True
1216   | otherwise   =
1217       tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
1218
1219 -- Instances
1220 instance Arbitrary NgramsRepoElement where
1221   arbitrary = elements $ map ngramsElementToRepo ns
1222     where
1223       NgramsTable ns = mockTable
1224