diff --git a/src/Gargantext/Core/NodeStory.hs b/src/Gargantext/Core/NodeStory.hs
index 44ffe15e6022ffc18b0da50479457af4698142f4..3ddb4dce9d03288be472deeab02c3a3907c76dd9 100644
--- a/src/Gargantext/Core/NodeStory.hs
+++ b/src/Gargantext/Core/NodeStory.hs
@@ -48,8 +48,6 @@ module Gargantext.Core.NodeStory
( module Gargantext.Core.NodeStory.Types
, getNodesArchiveHistory
, Archive(..)
- , nodeExists
- , getNodesIdWithType
, fromDBNodeStoryEnv
, upsertNodeStories
-- , getNodeStory
@@ -58,7 +56,6 @@ module Gargantext.Core.NodeStory
, currentVersion
, archiveStateFromList
, archiveStateToList
- , fixNodeStoryVersions
, fixChildrenDuplicatedAsParents
, getParentsChildren )
where
@@ -68,7 +65,6 @@ import Data.Map.Strict qualified as Map
import Data.Pool (Pool, withResource)
import Data.Set qualified as Set
import Database.PostgreSQL.Simple qualified as PGS
-import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.ToField qualified as PGS
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory.DB
@@ -78,12 +74,11 @@ import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) )
import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Prelude (HasConnectionPool(..))
import Gargantext.Prelude hiding (to)
-import Gargantext.Prelude.Database ( runPGSAdvisoryXactLock, runPGSExecute, runPGSQuery )
+import Gargantext.Prelude.Database ( runPGSAdvisoryXactLock, runPGSQuery )
getNodeStory' :: PGS.Connection -> NodeId -> IO ArchiveList
getNodeStory' c nId = do
- --res <- withResource pool $ \c -> runSelect c query :: IO [NodeStoryPoly NodeId Version Int Int NgramsRepoElement]
res <- runPGSQuery c nodeStoriesQuery (PGS.Only $ PGS.toField nId) :: IO [(Version, Ngrams.NgramsType, NgramsTerm, NgramsRepoElement)]
-- We have multiple rows with same node_id and different (ngrams_type_id, ngrams_id).
-- Need to create a map: {<node_id>: {<ngrams_type_id>: {<ngrams_id>: <data>}}}
@@ -97,14 +92,6 @@ getNodeStory' c nId = do
-- `node_stories_ngrams` without the `version` colum? Then we would
-- have `version` in only one place.
-{-
- let versionsS = Set.fromList $ map (\a -> a ^. a_version) dbData
- if Set.size versionsS > 1 then
- panic $ Text.pack $ "[getNodeStory] versions for " <> show nodeId <> " differ! " <> show versionsS
- else
- pure ()
--}
-
pure $ foldl' combine initArchive dbData
where
-- NOTE (<>) for Archive doesn't concatenate states, so we have to use `combine`
@@ -150,42 +137,25 @@ updateNodeStory c nodeId currentArchive newArchive = do
let currentSet = archiveStateSet currentList
let newSet = archiveStateSet newList
- -- printDebug "[updateNodeStory] new - current = " $ Set.difference newSet currentSet
let inserts = archiveStateListFilterFromSet (Set.difference newSet currentSet) newList
- -- printDebug "[updateNodeStory] inserts" inserts
- -- printDebug "[updateNodeStory] current - new" $ Set.difference currentSet newSet
let deletes = archiveStateListFilterFromSet (Set.difference currentSet newSet) currentList
- -- printDebug "[updateNodeStory] deletes" deletes
-- updates are the things that are in new but not in current
let commonSet = Set.intersection currentSet newSet
let commonNewList = archiveStateListFilterFromSet commonSet newList
let commonCurrentList = archiveStateListFilterFromSet commonSet currentList
let updates = Set.toList $ Set.difference (Set.fromList commonNewList) (Set.fromList commonCurrentList)
- -- printDebug "[updateNodeStory] updates" $ Text.unlines $ (Text.pack . show) <$> updates
-- 2. Perform inserts/deletes/updates
- -- printDebug "[updateNodeStory] applying inserts" inserts
insertArchiveStateList c nodeId (newArchive ^. a_version) inserts
- --printDebug "[updateNodeStory] insert applied" ()
- --TODO Use currentArchive ^. a_version in delete and report error
+ -- TODO Use currentArchive ^. a_version in delete and report error
-- if entries with (node_id, ngrams_type_id, ngrams_id) but
-- different version are found.
deleteArchiveStateList c nodeId deletes
- --printDebug "[updateNodeStory] delete applied" ()
updateArchiveStateList c nodeId (newArchive ^. a_version) updates
- --printDebug "[updateNodeStory] update applied" ()
pure ()
- -- where
- -- update = Update { uTable = nodeStoryTable
- -- , uUpdateWith = updateEasy (\(NodeStoryDB { node_id }) ->
- -- NodeStoryDB { archive = sqlValueJSONB $ Archive { _a_history = emptyHistory
- -- , ..}
- -- , .. })
- -- , uWhere = (\row -> node_id row .== sqlInt4 nId)
- -- , uReturning = rCount }
upsertNodeStories :: PGS.Connection -> NodeId -> ArchiveList -> IO ()
upsertNodeStories c nodeId newArchive = do
@@ -287,17 +257,7 @@ fromDBNodeStoryEnv :: Pool PGS.Connection -> IO NodeStoryEnv
fromDBNodeStoryEnv pool = do
-- tvar <- nodeStoryVar pool Nothing []
let saver_immediate nId a = do
- -- ns <- atomically $
- -- readTVar tvar
- -- -- fix children so their 'list' is the same as their parents'
- -- >>= pure . fixChildrenTermTypes
- -- -- fix children that don't have a parent anymore
- -- >>= pure . fixChildrenWithNoParent
- -- >>= writeTVar tvar
- -- >> readTVar tvar
withResource pool $ \c -> do
- --printDebug "[mkNodeStorySaver] will call writeNodeStories, ns" ns
- -- writeNodeStories c $ fixChildrenWithNoParent $ fixChildrenTermTypes ns
-- |NOTE Fixing a_state is kinda a hack. We shouldn't land
-- |with bad state in the first place.
@@ -310,10 +270,6 @@ fromDBNodeStoryEnv pool = do
let archive_saver_immediate nId a = withResource pool $ \c -> do
insertNodeArchiveHistory c nId (a ^. a_version) $ reverse $ a ^. a_history
pure $ a & a_history .~ []
- -- mapM_ (\(nId, a) -> do
- -- insertNodeArchiveHistory c nId (a ^. a_version) $ reverse $ a ^. a_history
- -- ) $ Map.toList nls
- -- pure $ clearHistory ns
pure $ NodeStoryEnv { _nse_saver_immediate = saver_immediate
, _nse_archive_saver_immediate = archive_saver_immediate
@@ -328,117 +284,3 @@ currentVersion listId = do
pool <- view connPool
nls <- liftBase $ withResource pool $ \c -> liftBase $ getNodeStory c listId
pure $ nls ^. unNodeStory . at listId . _Just . a_version
-
-
------------------------------------------
-
--- | To be called from the REPL
-fixNodeStoryVersions :: (HasNodeStory env err m) => m ()
-fixNodeStoryVersions = do
- pool <- view connPool
- _ <- liftBase $ withResource pool $ \c -> liftBase $ PGS.withTransaction c $ do
- nIds <- runPGSQuery c [sql| SELECT id FROM nodes WHERE ? |] (PGS.Only True) :: IO [PGS.Only Int64]
- -- printDebug "[fixNodeStoryVersions] nIds" nIds
- mapM_ (\(PGS.Only nId) -> do
- -- printDebug "[fixNodeStoryVersions] nId" nId
- updateVer c Ngrams.Authors nId
-
- updateVer c Ngrams.Institutes nId
-
- updateVer c Ngrams.Sources nId
-
- updateVer c Ngrams.NgramsTerms nId
-
- pure ()
- ) nIds
- pure ()
- where
- maxVerQuery :: PGS.Query
- maxVerQuery = [sql| SELECT max(version)
- FROM node_stories
- WHERE node_id = ?
- AND ngrams_type_id = ? |]
- updateVerQuery :: PGS.Query
- updateVerQuery = [sql| UPDATE node_stories
- SET version = ?
- WHERE node_id = ?
- AND ngrams_type_id = ? |]
- updateVer :: PGS.Connection -> Ngrams.NgramsType -> Int64 -> IO ()
- updateVer c ngramsType nId = do
- maxVer <- runPGSQuery c maxVerQuery (nId, ngramsType) :: IO [PGS.Only (Maybe Int64)]
- case maxVer of
- [] -> pure ()
- [PGS.Only Nothing] -> pure ()
- [PGS.Only (Just maxVersion)] -> do
- _ <- runPGSExecute c updateVerQuery (maxVersion, nId, ngramsType)
- pure ()
- _ -> panicTrace "Should get only 1 result!"
-
------------------------------------------
-
--- DEPRECATED
-
-
--- nodeStoryVar :: Pool PGS.Connection
--- -> Maybe (TVar NodeListStory)
--- -> [NodeId]
--- -> IO (TVar NodeListStory)
--- nodeStoryVar pool Nothing nIds = do
--- state' <- withResource pool $ \c -> nodeStoryIncrementalRead c Nothing nIds
--- atomically $ newTVar state'
--- nodeStoryVar pool (Just tv) nIds = do
--- nls <- atomically $ readTVar tv
--- nls' <- withResource pool
--- $ \c -> nodeStoryIncrementalRead c (Just nls) nIds
--- _ <- atomically $ writeTVar tv nls'
--- pure tv
-
--- clearHistory :: NodeListStory -> NodeListStory
--- clearHistory (NodeStory ns) = NodeStory $ ns & (traverse . a_history) .~ emptyHistory
--- where
--- emptyHistory = [] :: [NgramsStatePatch']
-
-
--- fixChildrenWithNoParent :: NodeListStory -> NodeListStory
--- fixChildrenWithNoParent (NodeStory nls) =
--- NodeStory $ Map.fromList [ (nId, a & a_state %~ fixChildrenWithNoParentStatePatch)
--- | (nId, a) <- Map.toList nls ]
-
-
--- fixChildrenTermTypes :: NodeListStory -> NodeListStory
--- fixChildrenTermTypes (NodeStory nls) =
--- NodeStory $ Map.fromList [ (nId, a & a_state %~ fixChildrenInNgramsStatePatch)
--- | (nId, a) <- Map.toList nls ]
-
-
--- nodeStoryIncrementalRead :: PGS.Connection -> Maybe NodeListStory -> [NodeId] -> IO NodeListStory
--- nodeStoryIncrementalRead _ Nothing [] = pure $ NodeStory Map.empty
--- nodeStoryIncrementalRead c Nothing (ni:ns) = do
--- m <- getNodeStory c ni
--- nodeStoryIncrementalRead c (Just m) ns
--- nodeStoryIncrementalRead c (Just nls) ns = foldM (\m n -> nodeStoryInc c m n) nls ns
-
--- nodeStoryDec :: Pool PGS.Connection -> NodeListStory -> NodeId -> IO NodeListStory
--- nodeStoryDec pool ns@(NodeStory nls) ni = do
--- case Map.lookup ni nls of
--- Nothing -> do
--- _ <- nodeStoryRemove pool ni
--- pure ns
--- Just _ -> do
--- let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
--- _ <- nodeStoryRemove pool ni
--- pure $ NodeStory ns'
-------------------------------------
-
-
--- writeNodeStories :: PGS.Connection -> NodeListStory -> IO ()
--- writeNodeStories c (NodeStory nls) = do
--- mapM_ (\(nId, a) -> upsertNodeStories c nId a) $ Map.toList nls
-
-
--- nodeStoryRemove :: Pool PGS.Connection -> NodeId -> IO Int64
--- nodeStoryRemove pool (NodeId nId) = withResource pool $ \c -> runDelete c delete
--- where
--- delete = Delete { dTable = nodeStoryTable
--- , dWhere = (\row -> node_id row .== sqlInt4 nId)
--- , dReturning = rCount }
diff --git a/src/Gargantext/Core/NodeStory/DB.hs b/src/Gargantext/Core/NodeStory/DB.hs
index 97b85c626a457a85e0bd7ba0d08d2b29fcc0c5d4..d4ae801324b63d9605d6891b4e60c0dcda785192 100644
--- a/src/Gargantext/Core/NodeStory/DB.hs
+++ b/src/Gargantext/Core/NodeStory/DB.hs
@@ -14,9 +14,7 @@ Portability : POSIX
{-# LANGUAGE QuasiQuotes #-}
module Gargantext.Core.NodeStory.DB
- ( nodeExists
- , getNodesIdWithType
- , getNodesArchiveHistory
+ ( getNodesArchiveHistory
, insertNodeArchiveHistory
, nodeStoriesQuery
, insertArchiveStateList
@@ -33,29 +31,15 @@ import Database.PostgreSQL.Simple qualified as PGS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Gargantext.API.Ngrams.Types
-import Gargantext.Core (toDBid)
import Gargantext.Core.NodeStory.Types ( a_state, a_version, ArchiveList, ArchiveStateList, NgramsStatePatch' )
import Gargantext.Core.Text.Ngrams (NgramsType)
-import Gargantext.Database.Admin.Types.Node ( NodeId(..), NodeType )
+import Gargantext.Database.Admin.Types.Node ( NodeId(..) )
import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Schema.Ngrams ()
import Gargantext.Prelude hiding (to)
import Gargantext.Prelude.Database ( runPGSExecute, runPGSExecuteMany, runPGSQuery, runPGSReturning )
-nodeExists :: PGS.Connection -> NodeId -> IO Bool
-nodeExists c nId = (== [PGS.Only True])
- <$> runPGSQuery c [sql| SELECT true FROM nodes WHERE id = ? LIMIT 1 |]
- (PGS.Only nId)
-
-getNodesIdWithType :: PGS.Connection -> NodeType -> IO [NodeId]
-getNodesIdWithType c nt = do
- ns <- runPGSQuery c query (PGS.Only $ toDBid nt)
- pure $ map (\(PGS.Only nId) -> UnsafeMkNodeId nId) ns
- where
- query :: PGS.Query
- query = [sql| SELECT id FROM nodes WHERE typename = ? |]
-
-- /!\ This function is using an hard coded parameter
-- which depends on the Ngrams List Flow
diff --git a/src/Gargantext/Core/NodeStory/Types.hs b/src/Gargantext/Core/NodeStory/Types.hs
index 2678a5a5a2fa4c049e5bd79eed58166faa309e85..a4e19104b823d06daece844e262ef36ef8b332e1 100644
--- a/src/Gargantext/Core/NodeStory/Types.hs
+++ b/src/Gargantext/Core/NodeStory/Types.hs
@@ -27,7 +27,6 @@ module Gargantext.Core.NodeStory.Types
, NodeListStory
, ArchiveList
, NodeStoryEnv(..)
- , initNodeStory
, nse_getter
, nse_getter_multi
, nse_saver_immediate
@@ -37,7 +36,6 @@ module Gargantext.Core.NodeStory.Types
, Archive(..)
, initArchive
, archiveAdvance
- , unionArchives
, a_history
, a_state
, a_version
@@ -144,16 +142,7 @@ instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
archiveAdvance :: (Semigroup s, Semigroup p) => Archive s p -> Archive s p -> Archive s p
archiveAdvance aOld aNew = aNew { _a_history = _a_history aNew <> _a_history aOld }
--- | This is to merge archive states.
-unionArchives :: (Semigroup s, Semigroup p) => Archive s p -> Archive s p -> Archive s p
-unionArchives aOld aNew = aNew { _a_state = _a_state aOld <> _a_state aNew
- , _a_history = _a_history aNew <> _a_history aOld }
-
-
------------------------------------------------------------------------
-initNodeStory :: (Monoid s, Semigroup p) => NodeId -> NodeStory s p
-initNodeStory ni = NodeStory $ Map.singleton ni initArchive
-
initArchive :: (Monoid s, Semigroup p) => Archive s p
initArchive = Archive { _a_version = 0
, _a_state = mempty