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