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