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.Functor (($>))
  41 import Data.Patch.Class (Replace, replace, Action(act), Applicable(..),
  42                          Composable(..), Transformable(..),
  43                          PairPatch(..), Patched, ConflictResolution,
  44                          ConflictResolutionReplace, ours)
  45 import qualified Data.Map.Strict.Patch as PM
  46 import Data.Monoid
  47 --import Data.Semigroup
  48 import Data.Set (Set)
  49 -- import qualified Data.List as List
  50 import Data.Maybe (catMaybes)
  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, Prism', prism', Iso', iso, from, (^..), (.~), (#), to, {-withIndex, folded, ifolded,-} view, (^.), (+~), (%~), at, _Just, Each(..), itraverse_, (.=), both, mapped)
  58 import Control.Monad (guard)
  59 import Control.Monad.Error.Class (MonadError, throwError)
  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)
  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.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)
  84 import Servant hiding (Patch)
  85 import Test.QuickCheck (elements)
  86 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  87
  88 ------------------------------------------------------------------------
  89 --data FacetFormat = Table | Chart
  90 data TabType   = Docs     | Terms  | Sources | Authors | Institutes | Trash
  91                | Contacts
  92   deriving (Generic, Enum, Bounded)
  93
  94 instance FromHttpApiData TabType
  95   where
  96     parseUrlPiece "Docs"       = pure Docs
  97     parseUrlPiece "Terms"      = pure Terms
  98     parseUrlPiece "Sources"    = pure Sources
  99     parseUrlPiece "Institutes" = pure Institutes
 100     parseUrlPiece "Authors"    = pure Authors
 101     parseUrlPiece "Trash"      = pure Trash
 102
 103     parseUrlPiece "Contacts"   = pure Contacts
 104
 105     parseUrlPiece _            = Left "Unexpected value of TabType"
 106
 107 instance ToParamSchema   TabType
 108 instance ToJSON    TabType
 109 instance FromJSON  TabType
 110 instance ToSchema  TabType
 111 instance Arbitrary TabType
 112   where
 113     arbitrary = elements [minBound .. maxBound]
 114
 115 newtype MSet a = MSet (Map a ())
 116   deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
 117
 118 instance ToJSON a => ToJSON (MSet a) where
 119   toJSON     (MSet m) = toJSON     (Map.keys m)
 120   toEncoding (MSet m) = toEncoding (Map.keys m)
 121
 122 mSetFromSet :: Set a -> MSet a
 123 mSetFromSet = MSet . Map.fromSet (const ())
 124
 125 mSetFromList :: Ord a => [a] -> MSet a
 126 mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
 127
 128 instance (Ord a, FromJSON a) => FromJSON (MSet a) where
 129   parseJSON = fmap mSetFromList . parseJSON
 130
 131 instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
 132   -- TODO
 133
 134 ------------------------------------------------------------------------
 135 type NgramsTerm = Text
 136
 137 data NgramsElement =
 138      NgramsElement { _ne_ngrams      :: NgramsTerm
 139                    , _ne_list        :: ListType
 140                    , _ne_occurrences :: Int
 141                    , _ne_parent      :: Maybe NgramsTerm
 142                    , _ne_children    :: MSet NgramsTerm
 143                    }
 144       deriving (Ord, Eq, Show, Generic)
 145
 146 deriveJSON (unPrefix "_ne_") ''NgramsElement
 147 makeLenses ''NgramsElement
 148
 149 instance ToSchema NgramsElement
 150 instance Arbitrary NgramsElement where
 151   arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
 152
 153 ------------------------------------------------------------------------
 154 newtype NgramsTable = NgramsTable [NgramsElement]
 155   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 156
 157 type ListNgrams = NgramsTable
 158
 159 makePrisms ''NgramsTable
 160
 161 -- | Question: why these repetition of Type in this instance
 162 -- may you document it please ?
 163 instance Each NgramsTable NgramsTable NgramsElement NgramsElement where
 164   each = _NgramsTable . each
 165
 166 -- TODO discuss
 167 -- | TODO Check N and Weight
 168 {-
 169 toNgramsElement :: [NgramsTableData] -> [NgramsElement]
 170 toNgramsElement ns = map toNgramsElement' ns
 171     where
 172       toNgramsElement' (NgramsTableData _ p t _ lt w) = NgramsElement t lt' (round w) p' c'
 173         where
 174           p' = case p of
 175                  Nothing -> Nothing
 176                  Just x  -> lookup x mapParent
 177           c' = maybe mempty identity $ lookup t mapChildren
 178           lt' = maybe (panic "API.Ngrams: listypeId") identity lt
 179
 180       mapParent :: Map Int Text
 181       mapParent   = Map.fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
 182
 183       mapChildren :: Map Text (Set Text)
 184       mapChildren = Map.mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
 185                   $ Map.fromListWith (<>)
 186                   $ map (first fromJust)
 187                   $ filter (isJust . fst)
 188                   $ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
 189 -}
 190
 191 mockTable :: NgramsTable
 192 mockTable = NgramsTable
 193   [ NgramsElement "animal"  GraphList     1  Nothing       (mSetFromList ["dog", "cat"])
 194   , NgramsElement "cat"     GraphList     1 (Just "animal") mempty
 195   , NgramsElement "cats"    StopList      4  Nothing        mempty
 196   , NgramsElement "dog"     GraphList     3 (Just "animal")(mSetFromList ["dogs"])
 197   , NgramsElement "dogs"    StopList      4 (Just "dog")    mempty
 198   , NgramsElement "fox"     GraphList     1  Nothing        mempty
 199   , NgramsElement "object"  CandidateList 2  Nothing        mempty
 200   , NgramsElement "nothing" StopList      4  Nothing        mempty
 201   , NgramsElement "organic" GraphList     3  Nothing        (mSetFromList ["flower"])
 202   , NgramsElement "flower"  GraphList     3 (Just "organic") mempty
 203   , NgramsElement "moon"    CandidateList 1  Nothing         mempty
 204   , NgramsElement "sky"     StopList      1  Nothing         mempty
 205   ]
 206
 207 instance Arbitrary NgramsTable where
 208   arbitrary = pure mockTable
 209
 210 instance ToSchema NgramsTable
 211
 212 ------------------------------------------------------------------------
 213 type NgramsTableMap = Map NgramsTerm NgramsElement
 214
 215 ------------------------------------------------------------------------
 216 -- On the Client side:
 217 --data Action = InGroup     NgramsId NgramsId
 218 --            | OutGroup    NgramsId NgramsId
 219 --            | SetListType NgramsId ListType
 220
 221 data PatchSet a = PatchSet
 222   { _rem :: Set a
 223   , _add :: Set a
 224   }
 225   deriving (Eq, Ord, Show, Generic)
 226
 227 makeLenses ''PatchSet
 228 makePrisms ''PatchSet
 229
 230 instance ToJSON a => ToJSON (PatchSet a) where
 231   toJSON     = genericToJSON     $ unPrefix "_"
 232   toEncoding = genericToEncoding $ unPrefix "_"
 233
 234 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
 235   parseJSON = genericParseJSON $ unPrefix "_"
 236
 237 {-
 238 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
 239   arbitrary = PatchSet <$> arbitrary <*> arbitrary
 240
 241 type instance Patched (PatchSet a) = Set a
 242
 243 type ConflictResolutionPatchSet a = SimpleConflictResolution' (Set a)
 244 type instance ConflictResolution (PatchSet a) = ConflictResolutionPatchSet a
 245
 246 instance Ord a => Semigroup (PatchSet a) where
 247   p <> q = PatchSet { _rem = (q ^. rem) `Set.difference` (p ^. add) <> p ^. rem
 248                     , _add = (q ^. add) `Set.difference` (p ^. rem) <> p ^. add
 249                     } -- TODO Review
 250
 251 instance Ord a => Monoid (PatchSet a) where
 252   mempty = PatchSet mempty mempty
 253
 254 instance Ord a => Group (PatchSet a) where
 255   invert (PatchSet r a) = PatchSet a r
 256
 257 instance Ord a => Composable (PatchSet a) where
 258   composable _ _ = undefined
 259
 260 instance Ord a => Action (PatchSet a) (Set a) where
 261   act p source = (source `Set.difference` (p ^. rem)) <> p ^. add
 262
 263 instance Applicable (PatchSet a) (Set a) where
 264   applicable _ _ = mempty
 265
 266 instance Ord a => Validity (PatchSet a) where
 267   validate p = check (Set.disjoint (p ^. rem) (p ^. add)) "_rem and _add should be dijoint"
 268
 269 instance Ord a => Transformable (PatchSet a) where
 270   transformable = undefined
 271
 272   conflicts _p _q = undefined
 273
 274   transformWith conflict p q = undefined conflict p q
 275
 276 instance ToSchema a => ToSchema (PatchSet a)
 277 -}
 278
 279 type AddRem = Replace (Maybe ())
 280
 281 remPatch, addPatch :: AddRem
 282 remPatch = replace (Just ()) Nothing
 283 addPatch = replace Nothing (Just ())
 284
 285 isRem :: Replace (Maybe ()) -> Bool
 286 isRem = (== remPatch)
 287
 288 type PatchMap = PM.PatchMap
 289
 290 newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
 291   deriving (Eq, Show, Generic, Validity, Semigroup, Monoid,
 292             Transformable, Composable)
 293
 294 type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
 295 type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
 296
 297 -- TODO this breaks module abstraction
 298 makePrisms ''PM.PatchMap
 299
 300 makePrisms ''PatchMSet
 301
 302 _PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
 303 _PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
 304   where
 305     f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
 306     f = Map.partition isRem >>> both %~ Map.keysSet
 307
 308     g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
 309     g (rems, adds) = Map.fromSet (const remPatch) rems
 310                   <> Map.fromSet (const addPatch) adds
 311
 312 instance Ord a => Action (PatchMSet a) (MSet a) where
 313   act (PatchMSet p) (MSet m) = MSet $ act p m
 314
 315 instance Ord a => Applicable (PatchMSet a) (MSet a) where
 316   applicable (PatchMSet p) (MSet m) = applicable p m
 317
 318 instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
 319   toJSON     = toJSON . view _PatchMSetIso
 320   toEncoding = toEncoding . view _PatchMSetIso
 321
 322 instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
 323   parseJSON = fmap (_PatchMSetIso #) . parseJSON
 324
 325 instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
 326   arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
 327
 328 instance ToSchema a => ToSchema (PatchMSet a) where
 329   -- TODO
 330   declareNamedSchema _ = undefined
 331
 332 type instance Patched (PatchMSet a) = MSet a
 333
 334 instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
 335   arbitrary = uncurry replace <$> arbitrary
 336     -- If they happen to be equal then the patch is Keep.
 337
 338 instance ToSchema a => ToSchema (Replace a) where
 339   declareNamedSchema (_ :: proxy (Replace a)) = do
 340     -- TODO Keep constructor is not supported here.
 341     aSchema <- declareSchemaRef (Proxy :: Proxy a)
 342     return $ NamedSchema (Just "Replace") $ mempty
 343       & type_ .~ SwaggerObject
 344       & properties .~
 345           InsOrdHashMap.fromList
 346           [ ("old", aSchema)
 347           , ("new", aSchema)
 348           ]
 349       & required .~ [ "old", "new" ]
 350
 351 data NgramsPatch =
 352      NgramsPatch { _patch_children :: PatchMSet NgramsTerm
 353                  , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
 354                  }
 355       deriving (Eq, Show, Generic)
 356
 357 deriveJSON (unPrefix "_") ''NgramsPatch
 358 makeLenses ''NgramsPatch
 359
 360 instance ToSchema  NgramsPatch
 361
 362 instance Arbitrary NgramsPatch where
 363   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 364
 365 type NgramsPatchIso = PairPatch (PatchMSet NgramsTerm) (Replace ListType)
 366
 367 _NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
 368 _NgramsPatch = iso (\(NgramsPatch c l) -> c :*: l) (\(c :*: l) -> NgramsPatch c l)
 369
 370 instance Semigroup NgramsPatch where
 371   p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
 372
 373 instance Monoid NgramsPatch where
 374   mempty = _NgramsPatch # mempty
 375
 376 instance Validity NgramsPatch where
 377   validate p = p ^. _NgramsPatch . to validate
 378
 379 instance Transformable NgramsPatch where
 380   transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 381
 382   conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 383
 384   transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
 385     where
 386       (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 387
 388 type ConflictResolutionNgramsPatch =
 389   ( ConflictResolutionPatchMSet NgramsTerm
 390   , ConflictResolutionReplace ListType
 391   )
 392 type instance ConflictResolution NgramsPatch =
 393   ConflictResolutionNgramsPatch
 394
 395 type PatchedNgramsPatch = (Set NgramsTerm, ListType)
 396   -- ~ Patched NgramsPatchIso
 397 type instance Patched NgramsPatch = PatchedNgramsPatch
 398
 399 instance Applicable NgramsPatch (Maybe NgramsElement) where
 400   applicable p Nothing   = check (p == mempty) "NgramsPatch should be empty here"
 401   applicable p (Just ne) =
 402     -- TODO how to patch _ne_parent ?
 403     applicable (p ^. patch_children) (ne ^. ne_children) <>
 404     applicable (p ^. patch_list)     (ne ^. ne_list)
 405
 406 instance Action NgramsPatch NgramsElement where
 407   act p = (ne_children %~ act (p ^. patch_children))
 408         . (ne_list     %~ act (p ^. patch_list))
 409
 410 instance Action NgramsPatch (Maybe NgramsElement) where
 411   act = fmap . act
 412
 413 newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
 414   deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
 415
 416 instance FromField NgramsTablePatch
 417   where
 418     fromField = fromField'
 419
 420 instance FromField (PatchMap NgramsType (PatchMap NodeId NgramsTablePatch))
 421   where
 422     fromField = fromField'
 423
 424 --instance (Ord k, Action pv (Maybe v)) => Action (PatchMap k pv) (Map k v) where
 425 --
 426 type instance ConflictResolution NgramsTablePatch =
 427   NgramsTerm -> ConflictResolutionNgramsPatch
 428
 429 type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
 430   -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
 431 type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
 432
 433 makePrisms ''NgramsTablePatch
 434 instance ToSchema  (PatchMap NgramsTerm NgramsPatch)
 435 instance ToSchema  NgramsTablePatch
 436
 437 instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
 438   applicable p = applicable (p ^. _NgramsTablePatch)
 439
 440 instance Action NgramsTablePatch (Maybe NgramsTableMap) where
 441   act p =
 442     fmap (execState (reParentNgramsTablePatch p)) .
 443     act (p ^. _NgramsTablePatch)
 444
 445 instance Arbitrary NgramsTablePatch where
 446   arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
 447
 448 -- Should it be less than an Lens' to preserve PatchMap's abstraction.
 449 -- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
 450 -- ntp_ngrams_patches = _NgramsTablePatch .  undefined
 451
 452 type ReParent a = forall m. MonadState NgramsTableMap m => a -> m ()
 453
 454 reParent :: Maybe NgramsTerm -> ReParent NgramsTerm
 455 reParent parent child = at child . _Just . ne_parent .= parent
 456
 457 reParentAddRem :: NgramsTerm -> NgramsTerm -> ReParent AddRem
 458 reParentAddRem parent child p =
 459   reParent (if isRem p then Nothing else Just parent) child
 460
 461 reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
 462 reParentNgramsPatch parent ngramsPatch =
 463   itraverse_ (reParentAddRem parent) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap)
 464   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 465
 466 reParentNgramsTablePatch :: ReParent NgramsTablePatch
 467 reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
 468   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 469
 470 ------------------------------------------------------------------------
 471 ------------------------------------------------------------------------
 472 type Version = Int
 473
 474 data Versioned a = Versioned
 475   { _v_version :: Version
 476   , _v_data    :: a
 477   }
 478   deriving (Generic, Show)
 479 deriveJSON (unPrefix "_v_") ''Versioned
 480 makeLenses ''Versioned
 481 instance ToSchema a => ToSchema (Versioned a)
 482 instance Arbitrary a => Arbitrary (Versioned a) where
 483   arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 484
 485 {-
 486 -- TODO sequencs of modifications (Patchs)
 487 type NgramsIdPatch = Patch NgramsId NgramsPatch
 488
 489 ngramsPatch :: Int -> NgramsPatch
 490 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
 491
 492 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 493 toEdit n p = Edit n p
 494 ngramsIdPatch :: Patch NgramsId NgramsPatch
 495 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 496                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 497                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 498                                        ]
 499
 500 -- applyPatchBack :: Patch -> IO Patch
 501 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 502 -}
 503 ------------------------------------------------------------------------
 504 ------------------------------------------------------------------------
 505 ------------------------------------------------------------------------
 506
 507 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 508                       :> QueryParam "ngramsType"   TabType
 509                       :> QueryParams "list"   ListId
 510                       :> QueryParam "limit"  Limit
 511                       :> QueryParam "offset" Offset
 512                       :> Get    '[JSON] (Versioned NgramsTable)
 513
 514 type TableNgramsApi = Summary " Table Ngrams API Change"
 515                       :> QueryParam "ngramsType"   TabType
 516                       :> QueryParam' '[Required, Strict] "list" ListId
 517                       :> ReqBody '[JSON] (Versioned NgramsTablePatch)
 518                       :> Put     '[JSON] (Versioned NgramsTablePatch)
 519
 520 data NgramError = UnsupportedVersion
 521   deriving (Show)
 522
 523 class HasNgramError e where
 524   _NgramError :: Prism' e NgramError
 525
 526 instance HasNgramError ServantErr where
 527   _NgramError = prism' make match
 528     where
 529       err = err500 { errBody = "NgramError: Unsupported version" }
 530       make UnsupportedVersion = err
 531       match e = guard (e == err) $> UnsupportedVersion
 532
 533 ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
 534 ngramError nne = throwError $ _NgramError # nne
 535
 536 {-
 537 -- TODO: Replace.old is ignored which means that if the current list
 538 -- `GraphList` and that the patch is `Replace CandidateList StopList` then
 539 -- the list is going to be `StopList` while it should keep `GraphList`.
 540 -- However this should not happen in non conflicting situations.
 541 mkListsUpdate :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)]
 542 mkListsUpdate nt patches =
 543   [ (ngramsTypeId nt, ng, listTypeId lt)
 544   | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 545   , lt <- patch ^.. patch_list . new
 546   ]
 547
 548 mkChildrenGroups :: (PatchSet NgramsTerm -> Set NgramsTerm)
 549                  -> NgramsType
 550                  -> NgramsTablePatch
 551                  -> [(NgramsTypeId, NgramsParent, NgramsChild)]
 552 mkChildrenGroups addOrRem nt patches =
 553   [ (ngramsTypeId nt, parent, child)
 554   | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 555   , child <- patch ^.. patch_children . to addOrRem . folded
 556   ]
 557 -}
 558
 559 ngramsTypeFromTabType :: Maybe TabType -> NgramsType
 560 ngramsTypeFromTabType maybeTabType =
 561   let lieu = "Garg.API.Ngrams: " :: Text in
 562     case maybeTabType of
 563           Nothing  -> panic (lieu <> "Indicate the Table")
 564           Just tab -> case tab of
 565               Sources    -> Ngrams.Sources
 566               Authors    -> Ngrams.Authors
 567               Institutes -> Ngrams.Institutes
 568               Terms      -> Ngrams.NgramsTerms
 569               _          -> panic $ lieu <> "No Ngrams for this tab"
 570
 571 ------------------------------------------------------------------------
 572 data Repo s p = Repo
 573   { _r_version :: Version
 574   , _r_state   :: s
 575   , _r_history :: [p]
 576     -- ^ first patch in the list is the most recent
 577   }
 578   deriving (Generic)
 579
 580 instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
 581   parseJSON = genericParseJSON $ unPrefix "_r_"
 582
 583 instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
 584   toJSON     = genericToJSON     $ unPrefix "_r_"
 585   toEncoding = genericToEncoding $ unPrefix "_r_"
 586
 587 makeLenses ''Repo
 588
 589 initRepo :: Monoid s => Repo s p
 590 initRepo = Repo 1 mempty []
 591
 592 type NgramsRepo       = Repo NgramsState NgramsStatePatch
 593 type NgramsState      = Map NgramsType (Map NodeId NgramsTableMap)
 594 type NgramsStatePatch = PatchMap NgramsType (PatchMap NodeId NgramsTablePatch)
 595
 596 initMockRepo :: NgramsRepo
 597 initMockRepo = Repo 1 s []
 598   where
 599     s = Map.singleton Ngrams.NgramsTerms
 600       $ Map.singleton 47254
 601       $ Map.fromList
 602       [ (n ^. ne_ngrams, n) | n <- mockTable ^. _NgramsTable ]
 603
 604 class HasRepoVar env where
 605   repoVar :: Getter env (MVar NgramsRepo)
 606
 607 instance HasRepoVar (MVar NgramsRepo) where
 608   repoVar = identity
 609
 610 class HasRepoSaver env where
 611   repoSaver :: Getter env (IO ())
 612
 613 instance HasRepoSaver (IO ()) where
 614   repoSaver = identity
 615
 616 type RepoCmdM env err m =
 617   ( MonadReader env m
 618   , MonadError err m
 619   , MonadIO m
 620   , HasRepoVar env
 621   , HasRepoSaver env
 622   )
 623 ------------------------------------------------------------------------
 624
 625 saveRepo :: ( MonadReader env m, MonadIO m, HasRepoSaver env )
 626          => m ()
 627 saveRepo = liftIO =<< view repoSaver
 628
 629 listTypeConflictResolution :: ListType -> ListType -> ListType
 630 listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
 631
 632 ngramsStatePatchConflictResolution
 633   :: NgramsType -> NodeId -> NgramsTerm
 634   -> ConflictResolutionNgramsPatch
 635 ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
 636   = (const ours, ours)
 637   -- undefined {- TODO think this through -}, listTypeConflictResolution)
 638
 639 class HasInvalidError e where
 640   _InvalidError :: Prism' e Validation
 641
 642 instance HasInvalidError ServantErr where
 643   _InvalidError = panic "error" {-prism' make match
 644     where
 645       err = err500 { errBody = "InvalidError" }
 646       make _ = err
 647       match e = guard (e == err) $> UnsupportedVersion-}
 648
 649 assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
 650 assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
 651
 652 -- Current state:
 653 --   Insertions are not considered as patches,
 654 --   they do not extend history,
 655 --   they do not bump version.
 656 insertNewOnly :: a -> Maybe a -> Maybe a
 657 insertNewOnly a = maybe (Just a) (const $ error "insertNewOnly: impossible")
 658   -- TODO error handling
 659
 660 something :: Monoid a => Maybe a -> a
 661 something Nothing  = mempty
 662 something (Just a) = a
 663
 664 putListNgrams :: RepoCmdM env err m
 665               => NodeId -> NgramsType
 666               -> [NgramsElement] -> m ()
 667 putListNgrams listId ngramsType nes = do
 668   var <- view repoVar
 669   liftIO $ modifyMVar_ var $
 670     pure . (r_state . at ngramsType %~ (Just . (at listId %~ insertNewOnly m) . something))
 671   saveRepo
 672   where
 673     m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
 674
 675 -- Apply the given patch to the DB and returns the patch to be applied on the
 676 -- client.
 677 -- TODO:
 678 -- In this perliminary version the OT aspect is missing, therefore the version
 679 -- number is always 1 and the returned patch is always empty.
 680 tableNgramsPatch :: (HasNgramError err, HasInvalidError err,
 681                      RepoCmdM env err m)
 682                  => CorpusId -> Maybe TabType -> ListId
 683                  -> Versioned NgramsTablePatch
 684                  -> m (Versioned NgramsTablePatch)
 685 tableNgramsPatch _corpusId maybeTabType listId (Versioned p_version p_table) = do
 686   let ngramsType        = ngramsTypeFromTabType maybeTabType
 687       (p0, p0_validity) = PM.singleton listId p_table
 688       (p, p_validity)   = PM.singleton ngramsType p0
 689
 690   assertValid p0_validity
 691   assertValid p_validity
 692
 693   var <- view repoVar
 694   (p'_applicable, vq') <- liftIO $ modifyMVar var $ \r ->
 695     let
 696       q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
 697       (p', q') = transformWith ngramsStatePatchConflictResolution p q
 698       r' = r & r_version +~ 1
 699              & r_state   %~ act p'
 700              & r_history %~ (p' :)
 701       q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
 702       p'_applicable = applicable p' (r ^. r_state)
 703     in
 704     pure (r', (p'_applicable, Versioned (r' ^. r_version) q'_table))
 705
 706   saveRepo
 707   assertValid p'_applicable
 708   pure vq'
 709
 710   {- DB version
 711   when (version /= 1) $ ngramError UnsupportedVersion
 712   updateNodeNgrams $ NodeNgramsUpdate
 713     { _nnu_user_list_id = listId
 714     , _nnu_lists_update = mkListsUpdate ngramsType patch
 715     , _nnu_rem_children = mkChildrenGroups _rem ngramsType patch
 716     , _nnu_add_children = mkChildrenGroups _add ngramsType patch
 717     }
 718   pure $ Versioned 1 mempty
 719   -}
 720
 721 mergeNgramsElement :: NgramsElement -> NgramsElement -> NgramsElement
 722 mergeNgramsElement _neOld neNew = neNew
 723   {-
 724   { _ne_list        :: ListType
 725   If we merge the parents/children we can potentially create cycles!
 726   , _ne_parent      :: Maybe NgramsTerm
 727   , _ne_children    :: MSet NgramsTerm
 728   }
 729   -}
 730
 731 getListNgrams :: RepoCmdM env err m
 732                 => [NodeId] -> NgramsType -> m (Versioned ListNgrams)
 733 getListNgrams nodeIds ngramsType = do
 734   v <- view repoVar
 735   repo <- liftIO $ readMVar v
 736
 737   let
 738     ngramsMap = repo ^. r_state . at ngramsType . _Just
 739
 740     ngrams =
 741       Map.unionsWith mergeNgramsElement
 742         [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
 743
 744   pure $ Versioned (repo ^. r_version) (NgramsTable (ngrams ^.. each))
 745
 746
 747 -- | TODO Errors management
 748 --  TODO: polymorphic for Annuaire or Corpus or ...
 749 -- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
 750 getTableNgrams :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
 751                => CorpusId -> Maybe TabType
 752                -> [ListId] -> Maybe Limit -> Maybe Offset
 753                -- -> Maybe MinSize -> Maybe MaxSize
 754                -- -> Maybe ListType
 755                -- -> Maybe Text -- full text search
 756                -> m (Versioned NgramsTable)
 757 getTableNgrams _cId maybeTabType listIds mlimit moffset = do
 758   let ngramsType = ngramsTypeFromTabType maybeTabType
 759
 760   let
 761     defaultLimit = 10 -- TODO
 762     limit_  = maybe defaultLimit identity mlimit
 763     offset_ = maybe 0 identity moffset
 764
 765   lists <- catMaybes <$> listsWith userMaster
 766   trace (show lists) $ getListNgrams (lists <> listIds) ngramsType
 767     & mapped . v_data . _NgramsTable %~ (take limit_ . drop offset_)
 768