src/Gargantext/API/Ngrams.hs

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