src/Gargantext/API/Ngrams.hs

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