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