Skip to content

H
haskell-gargantext
Commit a2788ade authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

[nodeStory] optimize node_stories table 

Read in backend works now, insert and upsert not yet.
parent f43b4bb1
Hide whitespace changes
Inline Side-by-side
Showing with 295 additions and 174 deletions
devops/postgres/upgrade/0.0.6.1.sql 0 → 100644
View file @ a2788ade
-- we will migrate data here
-- rename old table and create a new one
ALTER TABLE public.node_stories RENAME TO node_stories_old;
CREATE TABLE public.node_stories (
id SERIAL,
node_id INTEGER NOT NULL,
version INTEGER NOT NULL,
ngrams_type_id INTEGER NOT NULL,
ngrams_id INTEGER NOT NULL,
--children TEXT[],
ngrams_repo_element jsonb DEFAULT '{}'::jsonb NOT NULL,
PRIMARY KEY (id),
FOREIGN KEY (node_id) REFERENCES public.nodes(id) ON DELETE CASCADE,
FOREIGN KEY (ngrams_id) REFERENCES public.ngrams(id) ON DELETE CASCADE
);
ALTER TABLE public.node_stories OWNER TO gargantua;
CREATE UNIQUE INDEX ON public.node_stories USING btree (node_id, ngrams_type_id, ngrams_id);
-- Authors (ngrams_type_id = 1), see G.D.S.Ngrams.hs -> ngramsTypeId
INSERT INTO public.node_stories
(node_id, version, ngrams_type_id, ngrams_id, ngrams_repo_element)
SELECT node_id, (archive->'version')::int, 1, ngrams.id, j.value
FROM node_stories_old
CROSS JOIN jsonb_each(archive->'state'->'Authors') AS j
JOIN ngrams ON terms = j.key;
-- we will leave children for later, small steps
-- INSERT INTO public.node_stories
-- (node_id, version, ngrams_type_id, ngrams_id, children, ngrams_repo_element)
-- SELECT node_id, (archive->'version')::int, 1, ngrams.id, c.children, (j.value - 'children')
-- FROM node_stories_old
-- CROSS JOIN jsonb_each(archive->'state'->'Authors') AS j
-- CROSS JOIN LATERAL (SELECT array_agg(d.elem) AS children FROM jsonb_array_elements_text(j.value->'children') AS d(elem)) AS c
-- JOIN ngrams ON terms = j.key;
-- Institutes (ngrams_type_id = 2)
INSERT INTO public.node_stories
(node_id, version, ngrams_type_id, ngrams_id, ngrams_repo_element)
SELECT node_id, (archive->'version')::int, 2, ngrams.id, j.value
FROM node_stories_old
CROSS JOIN jsonb_each(archive->'state'->'Institutes') AS j
JOIN ngrams ON terms = j.key;
-- Sources (ngrams_type_id = 3)
INSERT INTO public.node_stories
(node_id, version, ngrams_type_id, ngrams_id, ngrams_repo_element)
SELECT node_id, (archive->'version')::int, 3, ngrams.id, j.value
FROM node_stories_old
CROSS JOIN jsonb_each(archive->'state'->'Sources') AS j
JOIN ngrams ON terms = j.key;
-- NgramsTerms (ngrams_type_id = 4)
INSERT INTO public.node_stories
(node_id, version, ngrams_type_id, ngrams_id, ngrams_repo_element)
SELECT node_id, (archive->'version')::int, 4, ngrams.id, j.value
FROM node_stories_old
CROSS JOIN jsonb_each(archive->'state'->'NgramsTerms') AS j
JOIN ngrams ON terms = j.key;
devops/postgres/upgrade/0.0.6.sql
View file @ a2788ade
......@@ -36,4 +36,3 @@ ALTER TABLE public.node_story_archive_history OWNER TO gargantua;
-- UNION (SELECT node_id, sid, 3 AS ngrams_type_id, "Sources" AS patch FROM q WHERE "Sources" IS NOT NULL)
-- ORDER BY node_id, ngrams_type_id, sid
-- ) AS t;
gargantext.cabal
View file @ a2788ade
......@@ -96,7 +96,6 @@ library
Gargantext.Core.Viz.Phylo.SynchronicClustering
Gargantext.Core.Viz.Types
other-modules:
ConcurrentTest
Gargantext.API.Admin.Auth
Gargantext.API.Admin.FrontEnd
Gargantext.API.Admin.Orchestrator
......
src/Gargantext/API/Ngrams.hs
View file @ a2788ade
......@@ -29,6 +29,7 @@ module Gargantext.API.Ngrams
, TableNgramsApiPut
, getTableNgrams
, getTableNgramsCorpus
, setListNgrams
--, rmListNgrams TODO fix before exporting
, apiNgramsTableCorpus
......
src/Gargantext/API/Ngrams/Tools.hs
View file @ a2788ade
......@@ -22,6 +22,7 @@ import Data.Hashable (Hashable)
import Data.Set (Set)
import Data.Validity
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Types (ListType(..), NodeId, NodeType(..), ListId)
import Gargantext.Database.Prelude (CmdM, HasConnectionPool(..))
import Gargantext.Database.Schema.Ngrams (NgramsType)
......@@ -29,7 +30,6 @@ import Gargantext.Prelude
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Gargantext.Core.NodeStory
import qualified Gargantext.Core.NodeStoryFile as NSF
......@@ -209,7 +209,7 @@ migrateFromDirToDb = do
_ <- mapM (\(nId, a) -> do
n <- liftBase $ nodeExists pool nId
case n of
False -> pure 0
False -> pure ()
True -> liftBase $ upsertNodeArchive pool nId a
) $ Map.toList nls
--_ <- nodeStoryIncs (Just $ NodeStory nls) listIds
......
src/Gargantext/API/Ngrams/Types.hs
View file @ a2788ade
......@@ -28,7 +28,7 @@ import Data.String (IsString, fromString)
import Data.Swagger hiding (version, patch)
import Data.Text (Text, pack, strip)
import Data.Validity
import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField, ResultError(ConversionFailed), returnError)
import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
import Database.PostgreSQL.Simple.ToField (ToField, toJSONField, toField)
import GHC.Generics (Generic)
import Gargantext.Core.Text (size)
......@@ -44,7 +44,6 @@ import Servant.Job.Utils (jsonOptions)
import Test.QuickCheck (elements, frequency)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Map.Strict.Patch as PM
import qualified Data.Set as Set
......@@ -124,7 +123,7 @@ instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
------------------------------------------------------------------------
newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text }
deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable, NFData)
deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable, NFData, FromField, ToField)
instance IsHashable NgramsTerm where
hash (NgramsTerm t) = hash t
instance Monoid NgramsTerm where
......@@ -133,18 +132,6 @@ instance FromJSONKey NgramsTerm where
fromJSONKey = FromJSONKeyTextParser $ \t -> pure $ NgramsTerm $ strip t
instance IsString NgramsTerm where
fromString s = NgramsTerm $ pack s
instance FromField NgramsTerm
where
fromField field mb = do
v <- fromField field mb
case fromJSON v of
Success a -> pure $ NgramsTerm $ strip a
Error _err -> returnError ConversionFailed field
$ List.intercalate " " [ "cannot parse hyperdata for JSON: "
, show v
]
instance ToField NgramsTerm where
toField (NgramsTerm n) = toField n
data RootParent = RootParent
......@@ -164,19 +151,20 @@ data NgramsRepoElement = NgramsRepoElement
, _nre_children :: !(MSet NgramsTerm)
}
deriving (Ord, Eq, Show, Generic)
deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
-- TODO
-- if ngrams & not size => size
-- drop occurrences
makeLenses ''NgramsRepoElement
instance ToSchema NgramsRepoElement where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
instance Serialise NgramsRepoElement
instance FromField NgramsRepoElement where
fromField = fromJSONField
instance ToField NgramsRepoElement where
toField = toJSONField
instance Serialise (MSet NgramsTerm)
instance Serialise NgramsRepoElement
data NgramsElement =
NgramsElement { _ne_ngrams :: NgramsTerm
......
src/Gargantext/Core/NodeStory.hs
View file @ a2788ade
......@@ -71,29 +71,29 @@ module Gargantext.Core.NodeStory
, a_state
, a_version
, nodeExists
, runPGSQuery
, getNodesIdWithType
, readNodeStoryEnv
, upsertNodeArchive
, getNodeStory )
, getNodeStory
, nodeStoriesQuery )
where
-- import Debug.Trace (traceShow)
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Codec.Serialise.Class
import Control.Arrow (returnA)
import Control.Concurrent (MVar(), withMVar, newMVar, modifyMVar_)
import Control.Exception (catch, throw, SomeException(..))
import Control.Lens (makeLenses, Getter, (^.), (.~), traverse)
import Control.Lens (makeLenses, Getter, (^.), (.~), (%~), traverse)
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson hiding ((.=), decode)
import Data.ByteString.Char8 (hPutStrLn)
import Data.Map.Strict (Map)
import Data.Maybe (catMaybes, mapMaybe)
import Data.Maybe (catMaybes)
import Data.Monoid
import Data.Pool (Pool, withResource)
import Data.Semigroup
import qualified Database.PostgreSQL.Simple as PGS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
......@@ -101,15 +101,14 @@ import GHC.Generics (Generic)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (NodeId(..), NodeType)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Prelude (CmdM', HasConnectionPool, HasConfig)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Prelude
import Opaleye (Column, DefaultFromField(..), Insert(..), Select, SqlInt4, SqlJsonb, Table, Update(..), (.==), fromPGSFromField, rCount, restrict, runInsert, runSelect, runUpdate, selectTable, sqlInt4, sqlValueJSONB, tableField, updateEasy)
import Opaleye.Internal.Table (Table(..))
import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
import System.IO (stderr)
import qualified Data.Map.Strict as Map
import qualified Data.Map.Strict.Patch as PM
import qualified Database.PostgreSQL.Simple as PGS
import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
------------------------------------------------------------------------
......@@ -185,6 +184,13 @@ instance DefaultFromField SqlJsonb (Archive NgramsState' NgramsStatePatch')
where
defaultFromField = fromPGSFromField
-- | Combine `NgramsState'`. This is because the structure is (Map
-- NgramsType (Map ...)) and the default `(<>)` operator is
-- left-biased
-- (https://hackage.haskell.org/package/containers-0.6.6/docs/Data-Map-Internal.html#v:union)
combineState :: NgramsState' -> NgramsState' -> NgramsState'
combineState = Map.unionWith (<>)
-- TODO Semigroup instance for unions
-- TODO check this
instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
......@@ -218,9 +224,9 @@ initNodeListStoryMock :: NodeListStory
initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
where
nodeListId = 0
archive = Archive { _a_version = 0
, _a_state = ngramsTableMap
, _a_history = [] }
archive = Archive { _a_version = 0
, _a_state = ngramsTableMap
, _a_history = [] }
ngramsTableMap = Map.singleton TableNgrams.NgramsTerms
$ Map.fromList
[ (n ^. ne_ngrams, ngramsElementToRepo n)
......@@ -239,17 +245,31 @@ makeLenses ''Archive
-----------------------------------------
data NodeStoryPoly a b = NodeStoryDB { node_id :: a
, archive :: b }
data NodeStoryPoly nid v ngtid ngid nre =
NodeStoryDB { node_id :: nid
, version :: v
, ngrams_type_id :: ngtid
, ngrams_id :: ngid
, ngrams_repo_element :: nre }
deriving (Eq)
type ArchiveQ = Archive NgramsState' NgramsStatePatch'
type NodeStoryWrite = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
type NodeStoryRead = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
data NodeStoryArchivePoly nid a =
NodeStoryArchiveDB { a_node_id :: nid
, archive :: a }
deriving (Eq)
$(makeAdaptorAndInstance "pNodeStory" ''NodeStoryPoly)
$(makeAdaptorAndInstance "pNodeArchiveStory" ''NodeStoryArchivePoly)
-- type NodeStoryWrite = NodeStoryPoly (Column SqlInt4) (Column SqlInt4) (Column SqlInt4) (Column SqlInt4) (Column SqlJsonb)
-- type NodeStoryRead = NodeStoryPoly (Column SqlInt4) (Column SqlInt4) (Column SqlInt4) (Column SqlInt4) (Column SqlJsonb)
-- type NodeStoryArchiveWrite = NodeStoryArchivePoly (Column SqlInt4) (Column SqlJsonb)
-- type NodeStoryArchiveRead = NodeStoryArchivePoly (Column SqlInt4) (Column SqlJsonb)
type ArchiveQ = Archive NgramsState' NgramsStatePatch'
-- DB stuff
runPGSExecuteMany :: (PGS.ToRow q) => Pool PGS.Connection -> PGS.Query -> [q] -> IO Int64
runPGSExecuteMany pool qs a = withResource pool $ \c -> catch (PGS.executeMany c qs a) (printError c)
......@@ -269,108 +289,158 @@ runPGSQuery pool q a = withResource pool $ \c -> catch (PGS.query c q a) (printE
nodeExists :: Pool PGS.Connection -> NodeId -> IO Bool
nodeExists pool nId = (== [PGS.Only True])
<$> runPGSQuery pool [sql|SELECT true FROM nodes WHERE id = ? AND ? |] (nId, True)
<$> runPGSQuery pool [sql| SELECT true FROM nodes WHERE id = ? LIMIT 1 |] (PGS.Only nId)
getNodesIdWithType :: Pool PGS.Connection -> NodeType -> IO [NodeId]
getNodesIdWithType pool nt = do
ns <- runPGSQuery pool query (nodeTypeId nt, True)
ns <- runPGSQuery pool query (PGS.Only nt)
pure $ map (\(PGS.Only nId) -> NodeId nId) ns
where
query :: PGS.Query
query = [sql|SELECT id FROM nodes WHERE typename = ? AND ? |]
query = [sql| SELECT id FROM nodes WHERE typename = ? |]
-- nodeStoryTable :: Table NodeStoryRead NodeStoryWrite
-- nodeStoryTable =
-- Table "node_stories"
-- ( pNodeStory NodeStoryDB { node_id = tableField "node_id"
-- , version = tableField "version"
-- , ngrams_type_id = tableField "ngrams_type_id"
-- , ngrams_id = tableField "ngrams_id"
-- , ngrams_repo_element = tableField "ngrams_repo_element"
-- } )
nodeStoryTable :: Table NodeStoryRead NodeStoryWrite
nodeStoryTable =
Table "node_stories"
( pNodeStory NodeStoryDB { node_id = tableField "node_id"
, archive = tableField "archive" } )
-- nodeStoryArchiveTable :: Table NodeStoryArchiveRead NodeStoryArchiveWrite
-- nodeStoryArchiveTable =
-- Table "node_story_archive_history"
-- ( pNodeArchiveStory NodeStoryArchiveDB { a_node_id = tableField "node_id"
-- , archive = tableField "archive" } )
nodeStorySelect :: Select NodeStoryRead
nodeStorySelect = selectTable nodeStoryTable
-- nodeStorySelect :: Select NodeStoryRead
-- nodeStorySelect = selectTable nodeStoryTable
-- TODO Check ordering, "first patch in the _a_history list is the most recent"
getNodeArchiveHistory :: Pool PGS.Connection -> NodeId -> IO [NgramsStatePatch']
getNodeArchiveHistory pool nodeId = do
as <- runPGSQuery pool query (nodeId, True)
let asTuples = mapMaybe (\(ngrams_type_id, ngrams, patch) -> (\ntId -> (ntId, ngrams, patch)) <$> (TableNgrams.fromNgramsTypeId ngrams_type_id)) as
pure $ (\(ntId, terms, patch) -> fst $ PM.singleton ntId (NgramsTablePatch $ fst $ PM.singleton terms patch)) <$> asTuples
as <- runPGSQuery pool query (PGS.Only nodeId) :: IO [(TableNgrams.NgramsType, NgramsTerm, NgramsPatch)]
pure $ (\(ngramsType, terms, patch) -> fst $ PM.singleton ngramsType (NgramsTablePatch $ fst $ PM.singleton terms patch)) <$> as
where
query :: PGS.Query
query = [sql|SELECT ngrams_type_id, terms, patch
FROM node_story_archive_history
JOIN ngrams ON ngrams.id = ngrams_id
WHERE node_id = ? AND ? |]
query = [sql| SELECT ngrams_type_id, terms, patch
FROM node_story_archive_history
JOIN ngrams ON ngrams.id = ngrams_id
WHERE node_id = ? |]
ngramsIdQuery :: PGS.Query
ngramsIdQuery = [sql| SELECT id FROM ngrams WHERE terms = ? |]
insertNodeArchiveHistory :: Pool PGS.Connection -> NodeId -> [NgramsStatePatch'] -> IO ()
insertNodeArchiveHistory _ _ [] = pure ()
insertNodeArchiveHistory pool nodeId (h:hs) = do
let tuples = mconcat $ (\(nType, (NgramsTablePatch patch)) ->
(\(term, p) ->
(nodeId, TableNgrams.ngramsTypeId nType, term, p)) <$> PM.toList patch) <$> PM.toList h :: [(NodeId, TableNgrams.NgramsTypeId, NgramsTerm, NgramsPatch)]
tuplesM <- mapM (\(nId, nTypeId, term, patch) -> do
ngrams <- runPGSQuery pool ngramsQuery (term, True)
pure $ (\(PGS.Only termId) -> (nId, nTypeId, termId, term, patch)) <$> (headMay ngrams)
) tuples :: IO [Maybe (NodeId, TableNgrams.NgramsTypeId, Int, NgramsTerm, NgramsPatch)]
_ <- runPGSExecuteMany pool query $ ((\(nId, nTypeId, termId, _term, patch) -> (nId, nTypeId, termId, patch)) <$> (catMaybes tuplesM))
(nodeId, nType, term, p)) <$> PM.toList patch) <$> PM.toList h :: [(NodeId, TableNgrams.NgramsType, NgramsTerm, NgramsPatch)]
tuplesM <- mapM (\(nId, nType, term, patch) -> do
ngrams <- runPGSQuery pool ngramsIdQuery (PGS.Only term)
pure $ (\(PGS.Only termId) -> (nId, nType, termId, term, patch)) <$> (headMay ngrams)
) tuples :: IO [Maybe (NodeId, TableNgrams.NgramsType, Int, NgramsTerm, NgramsPatch)]
_ <- runPGSExecuteMany pool query $ ((\(nId, nType, termId, _term, patch) -> (nId, nType, termId, patch)) <$> (catMaybes tuplesM))
_ <- insertNodeArchiveHistory pool nodeId hs
pure ()
where
ngramsQuery :: PGS.Query
ngramsQuery = [sql| SELECT id FROM ngrams WHERE terms = ? AND ? |]
query :: PGS.Query
query = [sql| INSERT INTO node_story_archive_history(node_id, ngrams_type_id, ngrams_id, patch) VALUES (?, ?, ?, ?) |]
getNodeStory :: Pool PGS.Connection -> NodeId -> IO NodeListStory
getNodeStory pool (NodeId nodeId) = do
res <- withResource pool $ \c -> runSelect c query :: IO [NodeStoryPoly NodeId ArchiveQ]
withArchive <- mapM (\(NodeStoryDB { node_id = nId, archive = Archive { .. } }) -> do
--a <- getNodeArchiveHistory pool nId
let a = [] :: [NgramsStatePatch']
-- Don't read whole history. Only state is needed and most recent changes.
pure (nId, Archive { _a_history = a, .. })) res
pure $ NodeStory $ Map.fromListWith (<>) withArchive
getNodeStory pool nId@(NodeId nodeId) = do
--res <- withResource pool $ \c -> runSelect c query :: IO [NodeStoryPoly NodeId Version Int Int NgramsRepoElement]
res <- runPGSQuery pool nodeStoriesQuery (PGS.Only nodeId) :: IO [(Version, TableNgrams.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>}}}
let dbData = map (\(version, ngramsType, ngrams, ngrams_repo_element) ->
Archive { _a_version = version
, _a_history = []
, _a_state = Map.singleton ngramsType $ Map.singleton ngrams ngrams_repo_element }) res
-- TODO (<>) for Archive doesn't concatenate states!
-- NOTE When concatenating, check that the same version is for all states
pure $ NodeStory $ Map.singleton nId $ foldl combine mempty dbData
--pure $ NodeStory $ Map.fromListWith (<>) $ (\(NodeStoryDB nId a) -> (nId, a)) <$> res
where
query :: Select NodeStoryRead
query = proc () -> do
row@(NodeStoryDB node_id _) <- nodeStorySelect -< ()
restrict -< node_id .== sqlInt4 nodeId
returnA -< row
insertNodeArchive :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO Int64
insertNodeArchive pool nodeId@(NodeId nId) (Archive {..}) = do
ret <- withResource pool $ \c -> runInsert c insert
-- query :: Select NodeStoryRead
-- query = proc () -> do
-- row@(NodeStoryDB node_id _) <- nodeStorySelect -< ()
-- restrict -< node_id .== sqlInt4 nodeId
-- returnA -< row
combine a1 a2 = a1 & a_state %~ combineState (a2 ^. a_state)
& a_version .~ (a2 ^. a_version) -- version should be updated from list, not taken from the empty Archive
nodeStoriesQuery :: PGS.Query
nodeStoriesQuery = [sql| SELECT version, ngrams_type_id, terms, ngrams_repo_element
FROM node_stories
JOIN ngrams ON ngrams.id = ngrams_id
WHERE node_id = ? |]
-- Functions to convert archive state (which is a Map NgramsType (Map
-- NgramsTerm NgramsRepoElement)) to/from a flat list
archiveStateAsList :: NgramsState' -> [(TableNgrams.NgramsType, NgramsTerm, NgramsRepoElement)]
archiveStateAsList s = mconcat $ (\(nt, ntm) -> (\(n, nre) -> (nt, n, nre)) <$> Map.toList ntm) <$> Map.toList s
-- archiveStateFromList :: [(TableNgrams.NgramsType, NgramsTerm, NgramsRepoElement)] -> NgramsState'
-- archiveStateFromList l = Map.fromListWith (<>) $ (\(nt, t, nre) -> (nt, Map.singleton t nre)) <$> l
-- | This function inserts whole new node story and archive for given node_id.
insertNodeStory :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO ()
insertNodeStory pool nodeId@(NodeId nId) (Archive {..}) = do
_ <- mapM (\(ngramsType, ngrams, ngramsRepoElement) -> do
termIdM <- runPGSQuery pool ngramsIdQuery (PGS.Only ngrams) :: IO [PGS.Only Int64]
case headMay termIdM of
Nothing -> pure 0
Just (PGS.Only termId) -> runPGSExecuteMany pool query [(nId, _a_version, ngramsType, termId, ngramsRepoElement)]) $ archiveStateAsList _a_state
-- runInsert c $ insert ngramsType ngrams ngramsRepoElement) $ archiveStateAsList _a_state
-- NOTE: It is assumed that the most recent change is the first in the
-- list, so we save these in reverse order
insertNodeArchiveHistory pool nodeId $ reverse _a_history
pure ret
pure ()
where
emptyHistory = [] :: [NgramsStatePatch']
insert = Insert { iTable = nodeStoryTable
, iRows = [NodeStoryDB { node_id = sqlInt4 nId
, archive = sqlValueJSONB $ Archive { _a_history = emptyHistory
, .. } }]
, iReturning = rCount
, iOnConflict = Nothing }
updateNodeArchive :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO Int64
updateNodeArchive pool nodeId@(NodeId nId) (Archive {..}) = do
ret <- withResource pool $ \c -> runUpdate c update
query :: PGS.Query
query = [sql| INSERT INTO node_stories(node_id, ngrams_type_id, ngrams_id, ngrams_repo_element) VALUES (?, ?, ?, ?) |]
-- insert ngramsType ngrams ngramsRepoElement =
-- Insert { iTable = nodeStoryTable
-- , iRows = [NodeStoryDB { node_id = sqlInt4 nId
-- , version = sqlInt4 _a_version
-- , ngrams_type_id = sqlInt4 $ TableNgrams.ngramsTypeId ngramsType
-- , ngrams_id = ...
-- , ngrams_repo_element = sqlValueJSONB ngramsRepoElement
-- }]
-- , iReturning = rCount
-- , iOnConflict = Nothing }
-- | This function updates the node story and archive for given node_id.
updateNodeStory :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO ()
updateNodeStory pool nodeId@(NodeId _nId) (Archive {..}) = do
-- TODO This requires updating current DB state (which is spanned
-- along many rows)
-- The idea is this: fetch all current state data from the DB
-- (locking the rows), perform a diff and update what is necessary.
-- ret <- withResource pool $ \c -> runUpdate c update
-- NOTE: It is assumed that the most recent change is the first in the
-- list, so we save these in reverse order
insertNodeArchiveHistory pool nodeId $ reverse _a_history
pure ret
where
emptyHistory = [] :: [NgramsStatePatch']
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 }
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 }
-- nodeStoryRemove :: Pool PGS.Connection -> NodeId -> IO Int64
-- nodeStoryRemove pool (NodeId nId) = withResource pool $ \c -> runDelete c delete
......@@ -379,12 +449,16 @@ updateNodeArchive pool nodeId@(NodeId nId) (Archive {..}) = do
-- , dWhere = (\row -> node_id row .== sqlInt4 nId)
-- , dReturning = rCount }
upsertNodeArchive :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO Int64
upsertNodeArchive :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO ()
upsertNodeArchive pool nId a = do
(NodeStory m) <- getNodeStory pool nId
case Map.lookup nId m of
Nothing -> insertNodeArchive pool nId a
Just _ -> updateNodeArchive pool nId a
Nothing -> do
_ <- insertNodeStory pool nId a
pure ()
Just _ -> do
_ <- updateNodeStory pool nId a
pure ()
writeNodeStories :: Pool PGS.Connection -> NodeListStory -> IO ()
writeNodeStories pool (NodeStory nls) = do
......
src/Gargantext/Database/Action/Metrics.hs
View file @ a2788ade
......@@ -27,7 +27,7 @@ import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diag
import Gargantext.Database.Prelude (runPGSQuery{-, formatPGSQuery-})
import Gargantext.API.Ngrams.Types (TabType(..), ngramsTypeFromTabType, NgramsTerm(..))
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core.NodeStory
import Gargantext.Core.NodeStory hiding (runPGSQuery)
import Gargantext.Core.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-})
import Database.PostgreSQL.Simple.ToField (toField, Action{-, ToField-})
import Gargantext.Core.Types (ListType(..), Limit, NodeType(..), ContextId)
......@@ -88,7 +88,7 @@ updateNgramsOccurrences cId mlId = do
updateNgramsOccurrences' :: (FlowCmdM env err m)
=> CorpusId -> Maybe ListId -> Maybe Limit -> TabType
=> CorpusId -> Maybe ListId -> Maybe Limit -> TabType
-> m [Int]
updateNgramsOccurrences' cId maybeListId maybeLimit tabType = do
......@@ -97,7 +97,7 @@ updateNgramsOccurrences' cId maybeListId maybeLimit tabType = do
Just lId' -> pure lId'
result <- getNgramsOccurrences cId lId tabType maybeLimit
let
toInsert :: [[Action]]
toInsert = map (\(ngramsTerm, score)
......@@ -121,7 +121,7 @@ updateNgramsOccurrences' cId maybeListId maybeLimit tabType = do
RETURNING 1
|]
let fields = map (\t-> QualifiedIdentifier Nothing t)
let fields = map (\t-> QualifiedIdentifier Nothing t)
$ map Text.pack ["int4", "int4","text","int4","int4"]
map (\(Only a) -> a) <$> runPGSQuery queryInsert (Only $ Values fields toInsert)
......@@ -163,7 +163,7 @@ updateContextScore cId maybeListId = do
Just lId' -> pure lId'
result <- getContextsNgramsScore cId lId Terms MapTerm Nothing
let
toInsert :: [[Action]]
toInsert = map (\(contextId, score)
......@@ -185,7 +185,7 @@ updateContextScore cId maybeListId = do
RETURNING 1
|]
let fields = map (\t-> QualifiedIdentifier Nothing t)
let fields = map (\t-> QualifiedIdentifier Nothing t)
$ map Text.pack ["int4", "int4","int4"]
map (\(Only a) -> a) <$> runPGSQuery queryInsert (Only $ Values fields toInsert)
......@@ -243,6 +243,3 @@ getNgrams lId tabType = do
take' :: Maybe Int -> [a] -> [a]
take' Nothing xs = xs
take' (Just n) xs = take n xs
src/Gargantext/Database/Admin/Config.hs
View file @ a2788ade
......@@ -113,4 +113,3 @@ nodeTypes = [ (n, toDBid n) | n <- allNodeTypes ]
fromNodeTypeId :: NodeTypeId -> NodeType
fromNodeTypeId tId = fromMaybe (panic $ pack $ "Type Id " <> show tId <> " does not exist")
(lookup tId nodeTypeInv)
src/Gargantext/Database/Admin/Types/Node.hs
View file @ a2788ade
......@@ -30,8 +30,8 @@ import Data.Morpheus.Types (GQLType)
import Data.Swagger
import Data.Text (Text, unpack, pack)
import Data.Time (UTCTime)
import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import Database.PostgreSQL.Simple.ToField (ToField, toField)
import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
import GHC.Generics (Generic)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import Gargantext.Database.Schema.Context
......@@ -357,6 +357,20 @@ data NodeType = NodeUser
deriving (Show, Read, Eq, Generic, Bounded, Enum)
instance GQLType NodeType
instance FromJSON NodeType
instance ToJSON NodeType
instance FromHttpApiData NodeType where
parseUrlPiece = Right . read . unpack
instance ToHttpApiData NodeType where
toUrlPiece = pack . show
instance ToParamSchema NodeType
instance ToSchema NodeType
instance Arbitrary NodeType where
arbitrary = elements allNodeTypes
instance FromField NodeType where
fromField = fromJSONField
instance ToField NodeType where
toField = toJSONField
allNodeTypes :: [NodeType]
......@@ -394,21 +408,6 @@ defaultName NodeFrameNotebook = "Code"
defaultName NodeFile = "File"
instance FromJSON NodeType
instance ToJSON NodeType
instance FromHttpApiData NodeType where
parseUrlPiece = Right . read . unpack
instance ToHttpApiData NodeType where
toUrlPiece = pack . show
instance ToParamSchema NodeType
instance ToSchema NodeType
instance Arbitrary NodeType where
arbitrary = elements allNodeTypes
------------------------------------------------------------------------
-- Instances
......@@ -451,4 +450,3 @@ instance DefaultFromField SqlText (Maybe Hash)
context2node :: Context a -> Node a
context2node (Context ci ch ct cu cp cn cd chy) = Node ci ch ct cu cp cn cd chy
src/Gargantext/Database/Query/Table/Ngrams.hs
View file @ a2788ade
......@@ -132,4 +132,3 @@ selectNgramsId' ns = runPGSQuery querySelectNgramsId ( PGS.Only
JOIN input_rows ir ON ir.terms = n.terms
GROUP BY n.terms, n.id
|]
src/Gargantext/Database/Query/Table/Node.hs
View file @ a2788ade
......@@ -26,7 +26,6 @@ import Control.Lens (set, view)
import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Database.PostgreSQL.Simple as DPS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Opaleye hiding (FromField)
import Prelude hiding (null, id, map, sum)
......@@ -41,6 +40,9 @@ import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Schema.Node
import Gargantext.Prelude hiding (sum, head)
import qualified Database.PostgreSQL.Simple as PGS
queryNodeSearchTable :: Select NodeSearchRead
queryNodeSearchTable = selectTable nodeTableSearch
......@@ -123,7 +125,7 @@ getClosestParentIdByType :: HasDBid NodeType
-> NodeType
-> Cmd err (Maybe NodeId)
getClosestParentIdByType nId nType = do
result <- runPGSQuery query (nId, 0 :: Int)
result <- runPGSQuery query (PGS.Only nId)
case result of
[(NodeId parentId, pTypename)] -> do
if toDBid nType == pTypename then
......@@ -132,12 +134,12 @@ getClosestParentIdByType nId nType = do
getClosestParentIdByType (NodeId parentId) nType
_ -> pure Nothing
where
query :: DPS.Query
query :: PGS.Query
query = [sql|
SELECT n2.id, n2.typename
FROM nodes n1
JOIN nodes n2 ON n1.parent_id = n2.id
WHERE n1.id = ? AND 0 = ?;
WHERE n1.id = ?;
|]
-- | Similar to `getClosestParentIdByType` but includes current node
......@@ -147,7 +149,7 @@ getClosestParentIdByType' :: HasDBid NodeType
-> NodeType
-> Cmd err (Maybe NodeId)
getClosestParentIdByType' nId nType = do
result <- runPGSQuery query (nId, 0 :: Int)
result <- runPGSQuery query (PGS.Only nId)
case result of
[(NodeId id, pTypename)] -> do
if toDBid nType == pTypename then
......@@ -156,11 +158,11 @@ getClosestParentIdByType' nId nType = do
getClosestParentIdByType nId nType
_ -> pure Nothing
where
query :: DPS.Query
query :: PGS.Query
query = [sql|
SELECT n.id, n.typename
FROM nodes n
WHERE n.id = ? AND 0 = ?;
WHERE n.id = ?;
|]
-- | Given a node id, find all it's children (no matter how deep) of
......@@ -170,15 +172,15 @@ getChildrenByType :: HasDBid NodeType
-> NodeType
-> Cmd err [NodeId]
getChildrenByType nId nType = do
result <- runPGSQuery query (nId, 0 :: Int)
result <- runPGSQuery query (PGS.Only nId)
children_lst <- mapM (\(id, _) -> getChildrenByType id nType) result
pure $ concat $ [fst <$> filter (\(_, pTypename) -> pTypename == toDBid nType) result] ++ children_lst
where
query :: DPS.Query
query :: PGS.Query
query = [sql|
SELECT n.id, n.typename
FROM nodes n
WHERE n.parent_id = ? AND 0 = ?;
WHERE n.parent_id = ?;
|]
------------------------------------------------------------------------
......@@ -231,8 +233,8 @@ selectNodesIdWithType nt = proc () -> do
------------------------------------------------------------------------
nodeExists :: (HasNodeError err) => NodeId -> Cmd err Bool
nodeExists nId = (== [DPS.Only True])
<$> runPGSQuery [sql|SELECT true FROM nodes WHERE id = ? AND ?|] (nId, True)
nodeExists nId = (== [PGS.Only True])
<$> runPGSQuery [sql|SELECT true FROM nodes WHERE id = ? |] (PGS.Only nId)
getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
getNode nId = do
......@@ -397,4 +399,3 @@ defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId
getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
src/Gargantext/Database/Schema/Ngrams.hs
View file @ a2788ade
......@@ -20,25 +20,27 @@ Ngrams connection to the Database.
module Gargantext.Database.Schema.Ngrams
where
import Data.Maybe (fromMaybe)
import Data.HashMap.Strict (HashMap)
import Data.Hashable (Hashable)
import Codec.Serialise (Serialise())
import Control.Lens (over)
import Control.Monad (mzero)
import Data.Maybe (fromMaybe)
import Data.HashMap.Strict (HashMap)
import Data.Hashable (Hashable)
import Data.Aeson
import Data.Aeson.Types (toJSONKeyText)
import Data.Map (fromList, lookup)
import Database.PostgreSQL.Simple.FromField (returnError, ResultError(..))
import Data.Text (Text, splitOn, pack, strip)
import Gargantext.Core.Types (TODO(..), Typed(..))
import Gargantext.Prelude
import Servant (FromHttpApiData(..), Proxy(..), ToHttpApiData(..))
import Text.Read (read)
import Gargantext.Core (HasDBid(..))
import Gargantext.Database.Types
import Gargantext.Database.Schema.Prelude
import qualified Database.PostgreSQL.Simple as PGS
import Text.Read (read)
import qualified Data.ByteString.Char8 as B
import qualified Data.HashMap.Strict as HashMap
import qualified Database.PostgreSQL.Simple as PGS
type NgramsId = Int
......@@ -82,8 +84,34 @@ ngramsTable = Table "ngrams" (pNgramsDb NgramsDB { _ngrams_id = optionalTable
-- ngrams in text fields of documents has Terms Type (i.e. either title or abstract)
data NgramsType = Authors | Institutes | Sources | NgramsTerms
deriving (Eq, Show, Read, Ord, Enum, Bounded, Generic)
instance Serialise NgramsType
instance FromJSON NgramsType
instance FromJSONKey NgramsType where
fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
instance ToJSON NgramsType
instance ToJSONKey NgramsType where
toJSONKey = toJSONKeyText (pack . show)
instance FromHttpApiData NgramsType where
parseUrlPiece n = pure $ (read . cs) n
instance ToHttpApiData NgramsType where
toUrlPiece = pack . show
instance ToParamSchema NgramsType where
toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
-- map NgramsType to its assigned id
instance FromField NgramsType where
fromField fld mdata =
case B.unpack `fmap` mdata of
Nothing -> returnError UnexpectedNull fld ""
Just dat -> do
n <- fromField fld mdata
if (n :: Int) > 0 then
case fromNgramsTypeId (NgramsTypeId n) of
Nothing -> returnError ConversionFailed fld dat
Just nt -> pure nt
else
returnError ConversionFailed fld dat
instance ToField NgramsType where
toField nt = toField $ ngramsTypeId nt
ngramsTypes :: [NgramsType]
......@@ -96,33 +124,13 @@ instance ToSchema NgramsType
newtype NgramsTypeId = NgramsTypeId Int
deriving (Eq, Show, Ord, Num)
instance ToField NgramsTypeId where
toField (NgramsTypeId n) = toField n
instance FromField NgramsTypeId where
fromField fld mdata = do
n <- fromField fld mdata
if (n :: Int) > 0 then return $ NgramsTypeId n
else mzero
instance FromJSON NgramsType
instance FromJSONKey NgramsType where
fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
instance ToJSON NgramsType
instance ToJSONKey NgramsType where
toJSONKey = toJSONKeyText (pack . show)
instance FromHttpApiData NgramsType where
parseUrlPiece n = pure $ (read . cs) n
instance ToHttpApiData NgramsType where
toUrlPiece = pack . show
instance ToParamSchema NgramsType where
toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
instance DefaultFromField (Nullable SqlInt4) NgramsTypeId
where
defaultFromField = fromPGSFromField
......
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