[ngrams] MVar -> TVar refactoring

Also, some fixes to NodeStory (it inserts ngrams when saving node
story, when they don't exist).
parent c085b660
Pipeline #5303 canceled with stages
in 7 minutes and 40 seconds
......@@ -129,6 +129,7 @@ library
Gargantext.Database.Admin.Types.Node
Gargantext.Database.Prelude
Gargantext.Database.Query.Facet
Gargantext.Database.Query.Table.Ngrams
Gargantext.Database.Query.Table.NgramsPostag
Gargantext.Database.Query.Table.Node
Gargantext.Database.Query.Table.Node.Error
......@@ -215,7 +216,6 @@ library
Gargantext.Core.Methods.Similarities.Accelerate.SpeGen
Gargantext.Core.Methods.Similarities.Conditional
Gargantext.Core.Methods.Similarities.Distributional
Gargantext.Core.NodeStoryFile
Gargantext.Core.Statistics
Gargantext.Core.Text.Convert
Gargantext.Core.Text.Corpus.API.Hal
......@@ -329,7 +329,6 @@ library
Gargantext.Database.Query.Table.Context
Gargantext.Database.Query.Table.ContextNodeNgrams
Gargantext.Database.Query.Table.ContextNodeNgrams2
Gargantext.Database.Query.Table.Ngrams
Gargantext.Database.Query.Table.Node.Children
Gargantext.Database.Query.Table.Node.Contact
Gargantext.Database.Query.Table.Node.Document.Add
......@@ -892,6 +891,7 @@ test-suite garg-test-tasty
Test.Core.Utils
Test.Database.Operations
Test.Database.Operations.DocumentSearch
Test.Database.Operations.NodeStory
Test.Database.Setup
Test.Database.Types
Test.Graph.Clustering
......@@ -1002,6 +1002,7 @@ test-suite garg-test-hspec
Test.API.Setup
Test.Database.Operations
Test.Database.Operations.DocumentSearch
Test.Database.Operations.NodeStory
Test.Database.Setup
Test.Database.Types
Test.Utils
......
......@@ -186,8 +186,8 @@ newEnv logger port file = do
!self_url_env <- parseBaseUrl $ "http://0.0.0.0:" <> show port
dbParam <- databaseParameters file
!pool <- newPool dbParam
--nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
!nodeStory_env <- readNodeStoryEnv pool
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath config_env)
!nodeStory_env <- fromDBNodeStoryEnv pool
!scrapers_env <- newJobEnv defaultSettings manager_env
secret <- Jobs.genSecret
......
......@@ -38,9 +38,9 @@ withDevEnv iniPath k = withLoggerHoisted Dev $ \logger -> do
newDevEnv logger = do
cfg <- readConfig iniPath
dbParam <- databaseParameters iniPath
--nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
--nodeStory_env <- fromDBNodeStoryEnv (_gc_repofilepath cfg)
pool <- newPool dbParam
nodeStory_env <- readNodeStoryEnv pool
nodeStory_env <- fromDBNodeStoryEnv pool
setts <- devSettings devJwkFile
mail <- Mail.readConfig iniPath
nlp_config <- NLP.readConfig iniPath
......
......@@ -87,7 +87,6 @@ module Gargantext.API.Ngrams
)
where
import Control.Concurrent
import Control.Lens ((.~), view, (^.), (^..), (+~), (%~), (.~), msumOf, at, _Just, Each(..), (%%~), mapped, ifolded, to, withIndex, over)
import Control.Monad.Reader
import Data.Aeson.Text qualified as DAT
......@@ -123,6 +122,7 @@ import Gargantext.Database.Schema.Node (node_id, node_parent_id, node_user_id)
import Gargantext.Prelude hiding (log, to, toLower, (%))
import Gargantext.Prelude.Clock (hasTime, getTime)
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import GHC.Conc (readTVar, writeTVar)
import Prelude (error)
import Servant hiding (Patch)
......@@ -249,7 +249,6 @@ addListNgrams listId ngramsType nes = do
-- | TODO: incr the Version number
-- && should use patch
-- UNSAFE
setListNgrams :: HasNodeStory env err m
=> NodeId
-> TableNgrams.NgramsType
......@@ -257,15 +256,16 @@ setListNgrams :: HasNodeStory env err m
-> m ()
setListNgrams listId ngramsType ns = do
-- printDebug "[setListNgrams]" (listId, ngramsType)
getter <- view hasNodeStory
var <- liftBase $ (getter ^. nse_getter) [listId]
liftBase $ modifyMVar_ var $
pure . ( unNodeStory
. at listId . _Just
. a_state
. at ngramsType
.~ Just ns
)
var <- getNodeStoryVar [listId]
liftBase $ atomically $ do
nls <- readTVar var
writeTVar var $
( unNodeStory
. at listId . _Just
. a_state
. at ngramsType
.~ Just ns
) nls
saveNodeStory
......@@ -292,57 +292,67 @@ commitStatePatch listId (Versioned _p_version p) = do
-- printDebug "[commitStatePatch]" listId
var <- getNodeStoryVar [listId]
archiveSaver <- view hasNodeArchiveStoryImmediateSaver
vq' <- liftBase $ modifyMVar var $ \ns -> do
let
a = ns ^. unNodeStory . at listId . _Just
-- apply patches from version p_version to a ^. a_version
-- TODO Check this
--q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
q = mconcat $ a ^. a_history
--printDebug "[commitStatePatch] transformWith" (p,q)
-- let tws s = case s of
-- (Mod p) -> "Mod"
-- _ -> "Rpl"
-- printDebug "[commitStatePatch] transformWith" (tws $ p ^. _NgramsPatch, tws $ q ^. _NgramsPatch)
let
(p', q') = transformWith ngramsStatePatchConflictResolution p q
a' = a & a_version +~ 1
& a_state %~ act p'
& a_history %~ (p' :)
{-
-- Ideally we would like to check these properties. However:
-- * They should be checked only to debug the code. The client data
-- should be able to trigger these.
-- * What kind of error should they throw (we are in IO here)?
-- * Should we keep modifyMVar?
-- * Should we throw the validation in an Exception, catch it around
-- modifyMVar and throw it back as an Error?
assertValid $ transformable p q
assertValid $ applicable p' (r ^. r_state)
-}
-- printDebug "[commitStatePatch] a version" (a ^. a_version)
-- printDebug "[commitStatePatch] a' version" (a' ^. a_version)
let newNs = ( ns & unNodeStory . at listId .~ (Just a')
, Versioned (a' ^. a_version) q'
)
-- NOTE Now is the only good time to save the archive history. We
-- have the handle to the MVar and we need to save its exact
-- snapshot. Node Story archive is a linear table, so it's only
-- couple of inserts, it shouldn't take long...
-- If we postponed saving the archive to the debounce action, we
-- would have issues like
-- https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/476
-- where the `q` computation from above (which uses the archive)
-- would cause incorrect patch application (before the previous
-- archive was saved and applied)
newNs' <- archiveSaver $ fst newNs
ns <- liftBase $ atomically $ readTVar var
let
a = ns ^. unNodeStory . at listId . _Just
-- apply patches from version p_version to a ^. a_version
-- TODO Check this
--q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
q = mconcat $ a ^. a_history
--printDebug "[commitStatePatch] transformWith" (p,q)
-- let tws s = case s of
-- (Mod p) -> "Mod"
-- _ -> "Rpl"
-- printDebug "[commitStatePatch] transformWith" (tws $ p ^. _NgramsPatch, tws $ q ^. _NgramsPatch)
pure (newNs', snd newNs)
let
(p', q') = transformWith ngramsStatePatchConflictResolution p q
a' = a & a_version +~ 1
& a_state %~ act p'
& a_history %~ (p' :)
{-
-- Ideally we would like to check these properties. However:
-- * They should be checked only to debug the code. The client data
-- should be able to trigger these.
-- * What kind of error should they throw (we are in IO here)?
-- * Should we keep modifyMVar?
-- * Should we throw the validation in an Exception, catch it around
-- modifyMVar and throw it back as an Error?
assertValid $ transformable p q
assertValid $ applicable p' (r ^. r_state)
-}
-- printDebug "[commitStatePatch] a version" (a ^. a_version)
-- printDebug "[commitStatePatch] a' version" (a' ^. a_version)
let newNs = ( ns & unNodeStory . at listId .~ (Just a')
, Versioned (a' ^. a_version) q'
)
-- NOTE Now is the only good time to save the archive history. We
-- have the handle to the MVar and we need to save its exact
-- snapshot. Node Story archive is a linear table, so it's only
-- couple of inserts, it shouldn't take long...
-- NOTE This is changed now. Before we used MVar's, now it's TVars
-- (MVar's blocked). It was wrapped in withMVar before, now we read
-- the TVar, modify archive with archiveSaver, then write the tvar.
-- pure (newNs', snd newNs)
-- writeTVar var newNs'
--pure newNs
-- If we postponed saving the archive to the debounce action, we
-- would have issues like
-- https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/476
-- where the `q` computation from above (which uses the archive)
-- would cause incorrect patch application (before the previous
-- archive was saved and applied)
-- newNs' <- archiveSaver $ fst newNs
liftBase $ do
newNs' <- archiveSaver $ fst newNs
atomically $ writeTVar var newNs'
-- Save new ngrams
_ <- insertNgrams (newNgramsFromNgramsStatePatch p)
......@@ -350,7 +360,7 @@ commitStatePatch listId (Versioned _p_version p) = do
-- saveNodeStory
saveNodeStoryImmediate
pure vq'
pure $ snd newNs
......@@ -363,7 +373,7 @@ tableNgramsPull :: HasNodeStory env err m
tableNgramsPull listId ngramsType p_version = do
-- printDebug "[tableNgramsPull]" (listId, ngramsType)
var <- getNodeStoryVar [listId]
r <- liftBase $ readMVar var
r <- liftBase $ atomically $ readTVar var
let
a = r ^. unNodeStory . at listId . _Just
......@@ -491,7 +501,7 @@ getNgramsTableMap :: HasNodeStory env err m
-> m (Versioned NgramsTableMap)
getNgramsTableMap nodeId ngramsType = do
v <- getNodeStoryVar [nodeId]
repo <- liftBase $ readMVar v
repo <- liftBase $ atomically $ readTVar v
pure $ Versioned (repo ^. unNodeStory . at nodeId . _Just . a_version)
(repo ^. unNodeStory . at nodeId . _Just . a_state . at ngramsType . _Just)
......
......@@ -31,6 +31,7 @@ import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Ngrams (setListNgrams)
import Gargantext.API.Ngrams.List.Types
import Gargantext.API.Ngrams.Prelude (getNgramsList)
import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
import Gargantext.API.Ngrams.Types
import Gargantext.API.Prelude (GargServer, GargM, GargError)
import Gargantext.API.Types
......@@ -47,6 +48,7 @@ import Gargantext.Database.Types (Indexed(..))
import Gargantext.Prelude hiding (concat, toList)
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import Gargantext.Utils.Servant qualified as GUS
import GHC.Conc (readTVar)
import Prelude qualified
import Protolude qualified as P
import Servant
......@@ -122,7 +124,11 @@ setList :: HasNodeStory env err m
setList l m = do
-- TODO check with Version for optim
-- printDebug "New list as file" l
_ <- mapM (\(nt, Versioned _v ns) -> setListNgrams l nt ns) $ toList m
_ <- mapM (\(nt, Versioned _v ns) -> (setListNgrams l nt ns)) $ toList m
v <- getNodeStoryVar [l]
-- liftBase $ do
-- ns <- atomically $ readTVar v
-- printDebug "[setList] node story: " ns
-- TODO reindex
pure True
......
......@@ -14,22 +14,20 @@ Portability : POSIX
module Gargantext.API.Ngrams.Tools
where
import Control.Concurrent
import Control.Lens (_Just, (^.), at, view, At, Index, IxValue)
import Control.Monad.Reader
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.Map.Strict qualified as Map
import Data.Pool (withResource)
import Data.Set qualified as Set
import Data.Validity
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.NodeStoryFile qualified as NSF
import Gargantext.Core.Types (ListType(..), NodeId, NodeType(..), ListId)
import Gargantext.Database.Prelude (HasConnectionPool(..))
-- import Gargantext.Core.NodeStoryFile qualified as NSF
import Gargantext.Core.Types (ListType(..), NodeId, ListId)
import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Prelude
import GHC.Conc (TVar, readTVar)
mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
......@@ -43,7 +41,7 @@ getRepo :: HasNodeStory env err m
getRepo listIds = do
f <- getNodeListStory
v <- liftBase $ f listIds
v' <- liftBase $ readMVar v
v' <- liftBase $ atomically $ readTVar v
pure $ v'
......@@ -58,7 +56,7 @@ repoSize repo node_id = Map.map Map.size state'
getNodeStoryVar :: HasNodeStory env err m
=> [ListId] -> m (MVar NodeListStory)
=> [ListId] -> m (TVar NodeListStory)
getNodeStoryVar l = do
f <- getNodeListStory
v <- liftBase $ f l
......@@ -66,7 +64,7 @@ getNodeStoryVar l = do
getNodeListStory :: HasNodeStory env err m
=> m ([NodeId] -> IO (MVar NodeListStory))
=> m ([NodeId] -> IO (TVar NodeListStory))
getNodeListStory = do
env <- view hasNodeStory
pure $ view nse_getter env
......@@ -228,20 +226,20 @@ getCoocByNgrams'' (Diagonal diag) (f1,f2) (m1,m2) =
------------------------------------------
migrateFromDirToDb :: (HasNodeStory env err m) -- , HasNodeStory env err m)
=> m ()
migrateFromDirToDb = do
pool <- view connPool
withResource pool $ \c -> do
listIds <- liftBase $ getNodesIdWithType c NodeList
-- printDebug "[migrateFromDirToDb] listIds" listIds
(NodeStory nls) <- NSF.getRepoReadConfig listIds
-- printDebug "[migrateFromDirToDb] nls" nls
_ <- mapM (\(nId, a) -> do
n <- liftBase $ nodeExists c nId
case n of
False -> pure ()
True -> liftBase $ upsertNodeStories c nId a
) $ Map.toList nls
--_ <- nodeStoryIncs (Just $ NodeStory nls) listIds
pure ()
-- migrateFromDirToDb :: (HasNodeStory env err m) -- , HasNodeStory env err m)
-- => m ()
-- migrateFromDirToDb = do
-- pool <- view connPool
-- withResource pool $ \c -> do
-- listIds <- liftBase $ getNodesIdWithType c NodeList
-- -- printDebug "[migrateFromDirToDb] listIds" listIds
-- (NodeStory nls) <- NSF.getRepoReadConfig listIds
-- -- printDebug "[migrateFromDirToDb] nls" nls
-- _ <- mapM (\(nId, a) -> do
-- n <- liftBase $ nodeExists c nId
-- case n of
-- False -> pure ()
-- True -> liftBase $ upsertNodeStories c nId a
-- ) $ Map.toList nls
-- --_ <- nodeStoryIncs (Just $ NodeStory nls) listIds
-- pure ()
This diff is collapsed.
......@@ -22,7 +22,7 @@ import Control.Lens (view)
import Data.ByteString.Lazy qualified as DBL
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Gargantext.Core.NodeStory hiding (readNodeStoryEnv)
import Gargantext.Core.NodeStory hiding (fromDBNodeStoryEnv)
import Gargantext.Core.Types (ListId, NodeId(..))
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
......
......@@ -17,7 +17,6 @@ Portability : POSIX
module Gargantext.Database.Action.Flow.List
where
import Control.Concurrent
import Control.Lens ((^.), (+~), (%~), at, (.~), _Just)
import Control.Monad.Reader
import Data.List qualified as List
......@@ -35,6 +34,7 @@ import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb,{- getCgramsId -})
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Prelude hiding (toList)
import GHC.Conc (readTVar, writeTVar)
-- FLOW LIST
-- 1. select specific terms of the corpus when compared with others langs
......@@ -202,8 +202,10 @@ putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
-- If valid the rest would be atomic and no merge is required.
-}
var <- getNodeStoryVar [listId]
liftBase $ modifyMVar_ var $ \r -> do
pure $ r & unNodeStory . at listId . _Just . a_version +~ 1
& unNodeStory . at listId . _Just . a_history %~ (p :)
& unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
liftBase $ atomically $ do
r <- readTVar var
writeTVar var $
r & unNodeStory . at listId . _Just . a_version +~ 1
& unNodeStory . at listId . _Just . a_history %~ (p :)
& unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
saveNodeStory
......@@ -54,7 +54,7 @@ newTestEnv testEnv logger port = do
dbParam <- pure $ testEnvToPgConnectionInfo testEnv
!pool <- newPool dbParam
!nodeStory_env <- readNodeStoryEnv pool
!nodeStory_env <- fromDBNodeStoryEnv pool
!scrapers_env <- ServantAsync.newJobEnv ServantAsync.defaultSettings manager_env
secret <- Jobs.genSecret
......
......@@ -26,6 +26,7 @@ import Gargantext.Database.Schema.Node (NodePoly(..))
import Gargantext.Prelude
import Test.API.Setup (setupEnvironment)
import Test.Database.Operations.DocumentSearch
import Test.Database.Operations.NodeStory
import Test.Database.Setup (withTestDB)
import Test.Database.Types
import Test.Hspec
......@@ -63,6 +64,11 @@ tests = sequential $ aroundAll withTestDB $ describe "Database" $ do
it "Can perform search by author in documents" corpusSearch02
it "Can perform more complex searches using the boolean API" corpusSearch03
it "Can correctly count doc score" corpusScore01
describe "Node story" $ do
it "Can create a list" createListTest
it "Can add query node story" queryNodeStoryTest
it "Can add new terms to node story" insertNewTermsToNodeStoryTest
it "Can add new terms (with children) to node story" insertNewTermsWithChildrenToNodeStoryTest
data ExpectedActual a =
Expected a
......
{-|
Module : Test.Database.Operations.NodeStory
Description : GarganText database tests
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Test.Database.Operations.NodeStory where
import Control.Monad.Reader
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Database.PostgreSQL.Simple qualified as PSQL
import Database.PostgreSQL.Simple.SqlQQ
import Gargantext.API.Ngrams (setListNgrams, saveNodeStoryImmediate)
import Gargantext.API.Ngrams.Types (MSet(..), NgramsRepoElement(..), NgramsTerm(..))
import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
import Gargantext.Core.NodeStory hiding (runPGSQuery)
import Gargantext.Core.Types.Individu
import Gargantext.Core.Types (ListType(..))
import Gargantext.Database.Action.User (getUserId)
import Gargantext.Database.Admin.Config (userMaster)
import Gargantext.Database.Prelude (runPGSQuery)
import Gargantext.Database.Query.Table.Ngrams (selectNgramsId)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Tree.Root
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Database.Schema.Node (NodePoly(..))
import Gargantext.Prelude
import GHC.Conc (readTVar)
import Test.Database.Types
import Test.Hspec.Expectations
import Test.Tasty.HUnit
createListTest :: TestEnv -> Assertion
createListTest env = do
flip runReaderT env $ runTestMonad $ do
-- NOTE(adn) We need to create user 'gargantua'(!!) in order
-- for 'addDocumentsToHyperCorpus' to work.
let user = UserName userMaster
parentId <- getRootId user
[corpus] <- getCorporaWithParentId parentId
let corpusId = _node_id corpus
userId <- getUserId user
listId <- getOrMkList corpusId userId
listId' <- getOrMkList corpusId userId
liftIO $ listId `shouldBe` listId'
queryNodeStoryTest :: TestEnv -> Assertion
queryNodeStoryTest env = do
flip runReaderT env $ runTestMonad $ do
-- NOTE(adn) We need to create user 'gargantua'(!!) in order
-- for 'addDocumentsToHyperCorpus' to work.
let user = UserName userMaster
parentId <- getRootId user
[corpus] <- getCorporaWithParentId parentId
let corpusId = _node_id corpus
userId <- getUserId user
listId <- getOrMkList corpusId userId
saveNodeStoryImmediate
v <- getNodeStoryVar [listId]
liftIO $ do
ns <- atomically $ readTVar v
ns `shouldBe` (NodeStory $ Map.singleton listId $ Archive { _a_version = 0
, _a_state = Map.empty
, _a_history = [] })
insertNewTermsToNodeStoryTest :: TestEnv -> Assertion
insertNewTermsToNodeStoryTest env = do
flip runReaderT env $ runTestMonad $ do
-- NOTE(adn) We need to create user 'gargantua'(!!) in order
-- for 'addDocumentsToHyperCorpus' to work.
let user = UserName userMaster
parentId <- getRootId user
[corpus] <- getCorporaWithParentId parentId
let corpusId = _node_id corpus
userId <- getUserId user
listId <- getOrMkList corpusId userId
v <- getNodeStoryVar [listId]
let nre = NgramsRepoElement { _nre_size = 1
, _nre_list = MapTerm
, _nre_root = Nothing
, _nre_parent = Nothing
, _nre_children = MSet Map.empty }
let terms = "hello"
let nls = Map.singleton (NgramsTerm terms) nre
setListNgrams listId NgramsTerms nls
liftIO $ do
ns <- atomically $ readTVar v
ns `shouldBe` (NodeStory $ Map.singleton listId $ Archive { _a_version = 0
, _a_state = Map.singleton NgramsTerms nls
, _a_history = [] })
-- check that the ngrams are in the DB as well
ngramsMap <- selectNgramsId [terms]
-- saveNodeStory is called by `setListNgrams`
liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` [terms]
-- _ <- insertNgrams [UnsafeNgrams { _ngramsTerms = terms
-- , _ngramsSize = 1 }]
-- Finally, check that node stories are inserted correctly
-- saveNodeStoryImmediate
dbTerms <- runPGSQuery [sql|
SELECT terms
FROM ngrams
JOIN node_stories ON ngrams.id = ngrams_id
WHERE node_id = ?
|] (PSQL.Only listId)
liftIO $ dbTerms `shouldBe` [PSQL.Only terms]
insertNewTermsWithChildrenToNodeStoryTest :: TestEnv -> Assertion
insertNewTermsWithChildrenToNodeStoryTest env = do
flip runReaderT env $ runTestMonad $ do
-- NOTE(adn) We need to create user 'gargantua'(!!) in order
-- for 'addDocumentsToHyperCorpus' to work.
let user = UserName userMaster
parentId <- getRootId user
[corpus] <- getCorporaWithParentId parentId
let corpusId = _node_id corpus
userId <- getUserId user
listId <- getOrMkList corpusId userId
v <- getNodeStoryVar [listId]
let tParent = NgramsTerm "hello"
let tChild = NgramsTerm "world"
let terms = unNgramsTerm <$> [tParent, tChild]
let nreParent = NgramsRepoElement { _nre_size = 1
, _nre_list = MapTerm
, _nre_root = Nothing
, _nre_parent = Nothing
, _nre_children = MSet $ Map.singleton tChild () }
let nreChild = NgramsRepoElement { _nre_size = 1
, _nre_list = MapTerm
, _nre_root = Nothing
, _nre_parent = Just tParent
, _nre_children = MSet Map.empty }
let nls = Map.fromList [(tParent, nreParent), (tChild, nreChild)]
setListNgrams listId NgramsTerms nls
liftIO $ do
ns <- atomically $ readTVar v
ns `shouldBe` (NodeStory $ Map.singleton listId $ Archive { _a_version = 0
, _a_state = Map.singleton NgramsTerms nls
, _a_history = [] })
-- `setListNgrams` calls saveNodeStory already so we should have
-- the terms in the DB by now
ngramsMap <- selectNgramsId terms
liftIO $ (snd <$> Map.toList ngramsMap) `shouldBe` terms
saveNodeStoryImmediate
dbTerms <- runPGSQuery [sql|
SELECT terms
FROM ngrams
JOIN node_stories ON ngrams.id = ngrams_id
WHERE node_id = ?
|] (PSQL.Only listId)
liftIO $ (Set.fromList $ (\(PSQL.Only t) -> t) <$> dbTerms) `shouldBe` (Set.fromList terms)
ngramsMap2 <- selectNgramsId terms
liftIO $ (Set.fromList (snd <$> Map.toList ngramsMap2)) `shouldBe` (Set.fromList terms)
-- let (Just (tParentId, _)) = head $ filter ((==) (unNgramsTerm tParent) . snd) $ Map.toList ngramsMap2
-- let (Just (tChildId, _)) = head $ filter ((==) (unNgramsTerm tChild) . snd) $ Map.toList ngramsMap2
-- [PSQL.Only tParentId'] <-
-- runPGSQuery [sql|SELECT parent_id FROM ngrams WHERE terms = ?|] (PSQL.Only tChild)
-- liftIO $ tParentId `shouldBe` tParentId'
......@@ -15,6 +15,7 @@ import Database.PostgreSQL.Simple.Options qualified as Client
import Database.PostgreSQL.Simple.Options qualified as Opts
import Database.Postgres.Temp qualified as Tmp
import Gargantext.API.Admin.EnvTypes (Mode(Mock))
import Gargantext.Core.NodeStory (fromDBNodeStoryEnv)
import Gargantext.Prelude
import Gargantext.Prelude.Config
import Gargantext.System.Logging (withLoggerHoisted)
......@@ -71,8 +72,13 @@ setup = do
(PG.close) 2 60 2
bootstrapDB db pool gargConfig
ugen <- emptyCounter
test_nodeStory <- fromDBNodeStoryEnv pool
withLoggerHoisted Mock $ \logger -> do
pure $ TestEnv (DBHandle pool db) gargConfig ugen logger
pure $ TestEnv { test_db = DBHandle pool db
, test_config = gargConfig
, test_nodeStory
, test_usernameGen = ugen
, test_logger = logger }
withTestDB :: (TestEnv -> IO ()) -> IO ()
withTestDB = bracket setup teardown
......
......@@ -32,6 +32,7 @@ import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Prelude
import Gargantext.Core.Mail.Types (HasMail(..))
import Gargantext.Core.NLP (HasNLPServer(..))
import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude (HasConfig(..), HasConnectionPool(..))
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Prelude.Config
......@@ -57,6 +58,7 @@ nextCounter (Counter ref) = atomicModifyIORef' ref (\old -> (succ old, old))
data TestEnv = TestEnv {
test_db :: !DBHandle
, test_config :: !GargConfig
, test_nodeStory :: !NodeStoryEnv
, test_usernameGen :: !Counter
, test_logger :: !(Logger (GargM TestEnv GargError))
}
......@@ -107,6 +109,23 @@ instance HasMail TestEnv where
, _mc_mail_password = "test"
, _mc_mail_login_type = NoAuth })
instance HasNodeStoryEnv TestEnv where
hasNodeStory = to test_nodeStory
instance HasNodeStoryVar TestEnv where
hasNodeStoryVar = hasNodeStory . nse_getter
instance HasNodeStorySaver TestEnv where
hasNodeStorySaver = hasNodeStory . nse_saver
instance HasNodeStoryImmediateSaver TestEnv where
hasNodeStoryImmediateSaver = hasNodeStory . nse_saver_immediate
instance HasNodeArchiveStoryImmediateSaver TestEnv where
hasNodeArchiveStoryImmediateSaver = hasNodeStory . nse_archive_saver_immediate
coreNLPConfig :: NLPServerConfig
coreNLPConfig =
let uri = parseURI "http://localhost:9000"
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment