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_history %~ mempty
 918              & r_state . at ngramsType %~
 919                (Just .
 920                  (at nodeId %~
 921                    ( Just
 922                    . (<> ns)
 923                    . something
 924                    )
 925                  )
 926                  . something
 927                )
 928   saveRepo
 929
 930
 931 -- TODO-ACCESS check
 932 tableNgramsPost :: RepoCmdM env err m
 933                 => TabType
 934                 -> NodeId
 935                 -> Maybe ListType
 936                 -> [NgramsTerm] -> m ()
 937 tableNgramsPost tabType nodeId mayList =
 938   putListNgrams nodeId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
 939
 940 currentVersion :: RepoCmdM env err m
 941                => m Version
 942 currentVersion = do
 943   var <- view repoVar
 944   r   <- liftBase $ readMVar var
 945   pure $ r ^. r_version
 946
 947 tableNgramsPull :: RepoCmdM env err m
 948                 => ListId
 949                 -> TableNgrams.NgramsType
 950                 -> Version
 951                 -> m (Versioned NgramsTablePatch)
 952 tableNgramsPull listId ngramsType p_version = do
 953   var <- view repoVar
 954   r <- liftBase $ readMVar var
 955
 956   let
 957     q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
 958     q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
 959
 960   pure (Versioned (r ^. r_version) q_table)
 961
 962 -- Apply the given patch to the DB and returns the patch to be applied on the
 963 -- client.
 964 -- TODO-ACCESS check
 965 tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
 966                  => TabType -> ListId
 967                  -> Versioned NgramsTablePatch
 968                  -> m (Versioned NgramsTablePatch)
 969 tableNgramsPut tabType listId (Versioned p_version p_table)
 970   | p_table == mempty = do
 971       let ngramsType        = ngramsTypeFromTabType tabType
 972       tableNgramsPull listId ngramsType p_version
 973
 974   | otherwise         = do
 975       let ngramsType        = ngramsTypeFromTabType tabType
 976           (p0, p0_validity) = PM.singleton listId p_table
 977           (p, p_validity)   = PM.singleton ngramsType p0
 978
 979       assertValid p0_validity
 980       assertValid p_validity
 981
 982       var <- view repoVar
 983       vq' <- liftBase $ modifyMVar var $ \r -> do
 984         let
 985           q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
 986           (p', q') = transformWith ngramsStatePatchConflictResolution p q
 987           r' = r & r_version +~ 1
 988                  & r_state   %~ act p'
 989                  & r_history %~ (p' :)
 990           q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
 991         {-
 992         -- Ideally we would like to check these properties. However:
 993         -- * They should be checked only to debug the code. The client data
 994         --   should be able to trigger these.
 995         -- * What kind of error should they throw (we are in IO here)?
 996         -- * Should we keep modifyMVar?
 997         -- * Should we throw the validation in an Exception, catch it around
 998         --   modifyMVar and throw it back as an Error?
 999         assertValid $ transformable p q
1000         assertValid $ applicable p' (r ^. r_state)
1001         -}
1002         pure (r', Versioned (r' ^. r_version) q'_table)
1003
1004       saveRepo
1005       pure vq'
1006
1007 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
1008 mergeNgramsElement _neOld neNew = neNew
1009   {-
1010   { _ne_list        :: ListType
1011   If we merge the parents/children we can potentially create cycles!
1012   , _ne_parent      :: Maybe NgramsTerm
1013   , _ne_children    :: MSet NgramsTerm
1014   }
1015   -}
1016
1017 getNgramsTableMap :: RepoCmdM env err m
1018                   => NodeId
1019                   -> TableNgrams.NgramsType
1020                   -> m (Versioned NgramsTableMap)
1021 getNgramsTableMap nodeId ngramsType = do
1022   v    <- view repoVar
1023   repo <- liftBase $ readMVar v
1024   pure $ Versioned (repo ^. r_version)
1025                    (repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
1026
1027 dumpJsonTableMap :: RepoCmdM env err m
1028                  => Text
1029                  -> NodeId
1030                  -> TableNgrams.NgramsType
1031                  -> m ()
1032 dumpJsonTableMap fpath nodeId ngramsType = do
1033   m <- getNgramsTableMap nodeId ngramsType
1034   liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m)
1035   pure ()
1036
1037 type MinSize = Int
1038 type MaxSize = Int
1039
1040 -- | TODO Errors management
1041 --  TODO: polymorphic for Annuaire or Corpus or ...
1042 -- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
1043 -- TODO: should take only one ListId
1044
1045 getTime' :: MonadBase IO m => m TimeSpec
1046 getTime' = liftBase $ getTime ProcessCPUTime
1047
1048
1049 getTableNgrams :: forall env err m.
1050                   (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
1051                => NodeType -> NodeId -> TabType
1052                -> ListId -> Limit -> Maybe Offset
1053                -> Maybe ListType
1054                -> Maybe MinSize -> Maybe MaxSize
1055                -> Maybe OrderBy
1056                -> (NgramsTerm -> Bool)
1057                -> m (Versioned NgramsTable)
1058 getTableNgrams _nType nId tabType listId limit_ offset
1059                listType minSize maxSize orderBy searchQuery = do
1060
1061   t0 <- getTime'
1062   -- lIds <- selectNodesWithUsername NodeList userMaster
1063   let
1064     ngramsType = ngramsTypeFromTabType tabType
1065     offset'  = maybe 0 identity offset
1066     listType' = maybe (const True) (==) listType
1067     minSize'  = maybe (const True) (<=) minSize
1068     maxSize'  = maybe (const True) (>=) maxSize
1069
1070     selected_node n = minSize'     s
1071                    && maxSize'     s
1072                    && searchQuery  (n ^. ne_ngrams)
1073                    && listType'    (n ^. ne_list)
1074       where
1075         s = n ^. ne_size
1076
1077     selected_inner roots n = maybe False (`Set.member` roots) (n ^. ne_root)
1078
1079     ---------------------------------------
1080     sortOnOrder Nothing = identity
1081     sortOnOrder (Just TermAsc)   = List.sortOn $ view ne_ngrams
1082     sortOnOrder (Just TermDesc)  = List.sortOn $ Down . view ne_ngrams
1083     sortOnOrder (Just ScoreAsc)  = List.sortOn $ view ne_occurrences
1084     sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view ne_occurrences
1085
1086     ---------------------------------------
1087     selectAndPaginate :: Map NgramsTerm NgramsElement -> [NgramsElement]
1088     selectAndPaginate tableMap = roots <> inners
1089       where
1090         list = tableMap ^.. each
1091         rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root") (tableMap ^. at r))
1092                              (ne ^. ne_root)
1093         selected_nodes = list & take limit_
1094                               . drop offset'
1095                               . filter selected_node
1096                               . sortOnOrder orderBy
1097         roots = rootOf <$> selected_nodes
1098         rootsSet = Set.fromList (_ne_ngrams <$> roots)
1099         inners = list & filter (selected_inner rootsSet)
1100
1101     ---------------------------------------
1102     setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
1103     setScores False table = pure table
1104     setScores True  table = do
1105       let ngrams_terms = (table ^.. each . ne_ngrams)
1106       t1 <- getTime'
1107       occurrences <- getOccByNgramsOnlyFast' nId
1108                                              listId
1109                                             ngramsType
1110                                             ngrams_terms
1111       t2 <- getTime'
1112       liftBase $ hprint stderr
1113         ("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
1114         (length ngrams_terms) t1 t2
1115       {-
1116       occurrences <- getOccByNgramsOnlySlow nType nId
1117                                             (lIds <> [listId])
1118                                             ngramsType
1119                                             ngrams_terms
1120       -}
1121       let
1122         setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
1123
1124       pure $ table & each %~ setOcc
1125     ---------------------------------------
1126
1127   -- lists <- catMaybes <$> listsWith userMaster
1128   -- trace (show lists) $
1129   -- getNgramsTableMap ({-lists <>-} listIds) ngramsType
1130
1131   let scoresNeeded = needsScores orderBy
1132   tableMap1 <- getNgramsTableMap listId ngramsType
1133   t1 <- getTime'
1134   tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
1135                                     . Map.mapWithKey ngramsElementFromRepo
1136   t2 <- getTime'
1137   tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
1138                                     . setScores (not scoresNeeded)
1139                                     . selectAndPaginate
1140   t3 <- getTime'
1141   liftBase $ hprint stderr
1142             ("getTableNgrams total=" % timeSpecs
1143                           % " map1=" % timeSpecs
1144                           % " map2=" % timeSpecs
1145                           % " map3=" % timeSpecs
1146                           % " sql="  % (if scoresNeeded then "map2" else "map3")
1147                           % "\n"
1148             ) t0 t3 t0 t1 t1 t2 t2 t3
1149   pure tableMap3
1150
1151
1152 scoresRecomputeTableNgrams :: forall env err m. (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env) => NodeId -> TabType -> ListId -> m Int
1153 scoresRecomputeTableNgrams nId tabType listId = do
1154   tableMap <- getNgramsTableMap listId ngramsType
1155   _ <- tableMap & v_data %%~ setScores
1156                            . Map.mapWithKey ngramsElementFromRepo
1157
1158   pure $ 1
1159   where
1160     ngramsType = ngramsTypeFromTabType tabType
1161
1162     setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t
1163     setScores table = do
1164       let ngrams_terms = (table ^.. each . ne_ngrams)
1165       occurrences <- getOccByNgramsOnlyFast' nId
1166                                              listId
1167                                             ngramsType
1168                                             ngrams_terms
1169       let
1170         setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
1171
1172       pure $ table & each %~ setOcc
1173
1174
1175
1176 -- APIs
1177
1178 -- TODO: find a better place for the code above, All APIs stay here
1179 type QueryParamR = QueryParam' '[Required, Strict]
1180
1181 data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
1182              deriving (Generic, Enum, Bounded, Read, Show)
1183
1184 instance FromHttpApiData OrderBy
1185   where
1186     parseUrlPiece "TermAsc"   = pure TermAsc
1187     parseUrlPiece "TermDesc"  = pure TermDesc
1188     parseUrlPiece "ScoreAsc"  = pure ScoreAsc
1189     parseUrlPiece "ScoreDesc" = pure ScoreDesc
1190     parseUrlPiece _           = Left "Unexpected value of OrderBy"
1191
1192
1193 instance ToParamSchema OrderBy
1194 instance FromJSON  OrderBy
1195 instance ToJSON    OrderBy
1196 instance ToSchema  OrderBy
1197 instance Arbitrary OrderBy
1198   where
1199     arbitrary = elements [minBound..maxBound]
1200
1201 needsScores :: Maybe OrderBy -> Bool
1202 needsScores (Just ScoreAsc)  = True
1203 needsScores (Just ScoreDesc) = True
1204 needsScores _ = False
1205
1206 type TableNgramsApiGet = Summary " Table Ngrams API Get"
1207                       :> QueryParamR "ngramsType"  TabType
1208                       :> QueryParamR "list"        ListId
1209                       :> QueryParamR "limit"       Limit
1210                       :> QueryParam  "offset"      Offset
1211                       :> QueryParam  "listType"    ListType
1212                       :> QueryParam  "minTermSize" MinSize
1213                       :> QueryParam  "maxTermSize" MaxSize
1214                       :> QueryParam  "orderBy"     OrderBy
1215                       :> QueryParam  "search"      Text
1216                       :> Get    '[JSON] (Versioned NgramsTable)
1217
1218 type TableNgramsApiPut = Summary " Table Ngrams API Change"
1219                        :> QueryParamR "ngramsType" TabType
1220                        :> QueryParamR "list"       ListId
1221                        :> ReqBody '[JSON] (Versioned NgramsTablePatch)
1222                        :> Put     '[JSON] (Versioned NgramsTablePatch)
1223
1224 type TableNgramsApiPost = Summary " Table Ngrams API Adds new ngrams"
1225                        :> QueryParamR "ngramsType" TabType
1226                        :> QueryParamR "list"       ListId
1227                        :> QueryParam  "listType"   ListType
1228                        :> ReqBody '[JSON] [NgramsTerm]
1229                        :> Post    '[JSON] ()
1230
1231 type RecomputeScoresNgramsApiGet = Summary " Recompute scores for ngrams table"
1232                        :> QueryParamR "ngramsType"  TabType
1233                        :> QueryParamR "list"        ListId
1234                        :> "recompute" :> Post '[JSON] Int
1235
1236 type TableNgramsApiGetVersion = Summary " Table Ngrams API Get Version"
1237                       :> QueryParamR "ngramsType"  TabType
1238                       :> QueryParamR "list"        ListId
1239                       :> Get    '[JSON] Version
1240
1241 type TableNgramsApi =  TableNgramsApiGet
1242                   :<|> TableNgramsApiPut
1243                   :<|> TableNgramsApiPost
1244                   :<|> RecomputeScoresNgramsApiGet
1245                   :<|> "version" :> TableNgramsApiGetVersion
1246
1247 getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
1248                => NodeId
1249                -> TabType
1250                -> ListId
1251                -> Limit
1252                -> Maybe Offset
1253                -> Maybe ListType
1254                -> Maybe MinSize -> Maybe MaxSize
1255                -> Maybe OrderBy
1256                -> Maybe Text -- full text search
1257                -> m (Versioned NgramsTable)
1258 getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
1259   getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
1260     where
1261       searchQuery = maybe (const True) isInfixOf mt
1262
1263 getTableNgramsVersion :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
1264                => NodeId
1265                -> TabType
1266                -> ListId
1267                -> m Version
1268 getTableNgramsVersion nId tabType listId = do
1269   -- TODO: limit?
1270   Versioned { _v_version = v } <- getTableNgramsCorpus nId tabType listId 100000 Nothing Nothing Nothing Nothing Nothing Nothing
1271   pure v
1272
1273 -- | Text search is deactivated for now for ngrams by doc only
1274 getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
1275                => DocId -> TabType
1276                -> ListId -> Limit -> Maybe Offset
1277                -> Maybe ListType
1278                -> Maybe MinSize -> Maybe MaxSize
1279                -> Maybe OrderBy
1280                -> Maybe Text -- full text search
1281                -> m (Versioned NgramsTable)
1282 getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do
1283   ns <- selectNodesWithUsername NodeList userMaster
1284   let ngramsType = ngramsTypeFromTabType tabType
1285   ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
1286   let searchQuery = flip S.member (S.fromList ngs)
1287   getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
1288
1289
1290
1291 apiNgramsTableCorpus :: ( RepoCmdM env err m
1292                         , HasNodeError err
1293                         , HasInvalidError err
1294                         , HasConnectionPool env
1295                         , HasConfig         env
1296                         )
1297                      => NodeId -> ServerT TableNgramsApi m
1298 apiNgramsTableCorpus cId =  getTableNgramsCorpus cId
1299                        :<|> tableNgramsPut
1300                        :<|> tableNgramsPost
1301                        :<|> scoresRecomputeTableNgrams cId
1302                        :<|> getTableNgramsVersion cId
1303
1304 apiNgramsTableDoc :: ( RepoCmdM env err m
1305                      , HasNodeError err
1306                      , HasInvalidError err
1307                      , HasConnectionPool env
1308                      , HasConfig         env
1309                      )
1310                   => DocId -> ServerT TableNgramsApi m
1311 apiNgramsTableDoc dId =  getTableNgramsDoc dId
1312                     :<|> tableNgramsPut
1313                     :<|> tableNgramsPost
1314                     :<|> scoresRecomputeTableNgrams dId
1315                     :<|> getTableNgramsVersion dId
1316                     -- > add new ngrams in database (TODO AD)
1317                     -- > index all the corpus accordingly (TODO AD)
1318
1319 listNgramsChangedSince :: RepoCmdM env err m
1320                        => ListId -> TableNgrams.NgramsType -> Version -> m (Versioned Bool)
1321 listNgramsChangedSince listId ngramsType version
1322   | version < 0 =
1323       Versioned <$> currentVersion <*> pure True
1324   | otherwise   =
1325       tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
1326
1327 -- Instances
1328 instance Arbitrary NgramsRepoElement where
1329   arbitrary = elements $ map ngramsElementToRepo ns
1330     where
1331       NgramsTable ns = mockTable
1332
1333 --{-
1334 instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
1335   where
1336     parseUrlPiece x = maybeToEither x (decode $ cs x)