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