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