Commit 1f2d7f5c authored by Alexandre Delanoë's avatar Alexandre Delanoë

Merge branch 'dev' into stable

parents a854f24e 1f5ceb16
Pipeline #677 failed with stage
......@@ -19,23 +19,20 @@ Import a corpus binary.
module Main where
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import System.Environment (getArgs)
import Gargantext.Prelude
import Gargantext.Database.Flow (FlowCmdM, flowCorpusFile, getOrMkRoot)
import Gargantext.Text.Corpus.Parsers (FileFormat(..))
import Gargantext.Database.Flow (getOrMkRoot, getOrMkRootWithCorpus)
import Gargantext.Database.Schema.Node (getOrMkList)
import Gargantext.Database.Utils (Cmd, )
import Gargantext.Database.Types.Node (CorpusId, toHyperdataDocument, RootId)
import Gargantext.Database.Types.Node (CorpusId, RootId, HyperdataCorpus, ListId)
import Gargantext.Database.Schema.User (insertUsersDemo, UserId)
import Gargantext.Text.Terms (TermType(..))
import Gargantext.Core (Lang(..))
import Gargantext.API.Types (GargError)
import Gargantext.API.Node () -- instances
import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
--import Gargantext.Text.Corpus.Parsers.GrandDebat (readFile, GrandDebatReference(..))
import Data.Text (Text)
import qualified Data.Text as Text
import Control.Monad.IO.Class (liftIO)
import Gargantext.API.Settings (withDevEnv, runCmdDev)
import Gargantext.Database.Config (userMaster, corpusMasterName)
import Gargantext.Database.Init (initTriggers)
main :: IO ()
main = do
[iniPath] <- getArgs
......@@ -44,11 +41,21 @@ main = do
createUsers = insertUsersDemo
let
mkRoots :: Cmd GargError (UserId, RootId)
mkRoots = getOrMkRoot "user1"
mkRoots :: Cmd GargError [(UserId, RootId)]
mkRoots = mapM getOrMkRoot ["gargantua", "user1", "user2"]
-- TODO create all users roots
let
initMaster :: Cmd GargError (UserId, RootId, CorpusId, ListId)
initMaster = do
(masterUserId, masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster (Left corpusMasterName) (Nothing :: Maybe HyperdataCorpus)
masterListId <- getOrMkList masterCorpusId masterUserId
_ <- initTriggers masterListId
pure (masterUserId, masterRootId, masterCorpusId, masterListId)
withDevEnv iniPath $ \env -> do
_ <- runCmdDev env createUsers
_ <- runCmdDev env mkRoots
x <- runCmdDev env initMaster
putStrLn $ show x
pure ()
#!/bin/bash
if git --version;
then
echo "git installed, ok"
else
sudo apt update && sudo apt install git
fi
sudo apt update
sudo apt install liblzma-dev libpcre3-dev libblas-dev liblapack-dev pkg-config libgsl-dev libbz2-dev postgresql postgresql-server-dev-9.6 nginx libigraph-dev
#echo "Which user?"
#read USER
#sudo adduser --disabled-password --gecos "" $USER
#sudo su $USER
curl -sSL https://get.haskellstack.org/ | sh
stack update
stack upgrade
git clone https://gitlab.iscpif.fr/gargantext/haskell-gargantext.git
cd haskell-gargantext
git clone https://gitlab.iscpif.fr/gargantext/purescript-gargantext
mkdir deps
cd deps
git clone https://gitlab.iscpif.fr/gargantext/clustering-louvain.git
git clone https://github.com/np/servant-job.git
git clone https://github.com/np/patches-map
git clone https://gitlab.com/npouillard/patches-class.git
git clone https://github.com/delanoe/haskell-opaleye
git clone -b next --single-branch https://github.com/delanoe/hsparql
cd ..
stack setup
stack build
stack install
# Specific to our servers
### Configure timezone and locale ###################################
echo "########### LOCALES & TZ #################"
echo "Europe/Paris" > /etc/timezone
dpkg-reconfigure --frontend=noninteractive tzdata
#ENV TZ "Europe/Paris"
sed -i -e 's/# en_GB.UTF-8 UTF-8/en_GB.UTF-8 UTF-8/' /etc/locale.gen && \
sed -i -e 's/# fr_FR.UTF-8 UTF-8/fr_FR.UTF-8 UTF-8/' /etc/locale.gen && \
locale-gen && \
update-locale LANG=fr_FR.UTF-8 && \
update-locale LANGUAGE=fr_FR.UTF-8 && \
update-locale LC_ALL=fr_FR.UTF-8
################################################################
# Database configuration
# CREATE USER gargantua WITH PASSWORD $(grep DB_PASS gargantext.ini)
# GRANT ALL PRIVILEGES ON DATABASE gargandbV4 to gargantua
#######################################################################
## POSTGRESQL DATA (as ROOT)
#######################################################################
sed -iP "s%^data_directory.*%data_directory = \'\/srv\/gargandata\'%" /etc/postgresql/9.6/main/postgresql.conf
echo "host all all 0.0.0.0/0 md5" >> /etc/postgresql/9.6/main/pg_hba.conf
echo "listen_addresses='*'" >> /etc/postgresql/9.6/main/postgresql.conf
......@@ -14,5 +14,5 @@ sudo apt install liblzma-dev libpcre3-dev libblas-dev liblapack-dev pkg-config l
# Phylo management
sudo apt install graphviz
sudo apt install postgresql-server-dev-9.6
sudo apt install postgresql-server-dev-11
#!/bin/bash
git clone https://gitlab.iscpif.fr/gargantext/clustering-louvain-cplusplus.git
cd clustering-louvain-cplusplus
./install
cd ..
sudo apt install default-jdk
wget https://dl.gargantext.org/coreNLP.tar.bz2
tar xvjf coreNLP.tar.bz2
# ./startServer.sh
This diff is collapsed.
##
# You should look at the following URL's in order to grasp a solid understanding
# of Nginx configuration files in order to fully unleash the power of Nginx.
# http://wiki.nginx.org/Pitfalls
# http://wiki.nginx.org/QuickStart
# http://wiki.nginx.org/Configuration
#
# Generally, you will want to move this file somewhere, and start with a clean
# file but keep this around for reference. Or just disable in sites-enabled.
#
# Please see /usr/share/doc/nginx-doc/examples/ for more detailed examples.
##
server {
if ($host = dev.gargantext.org) {
return 301 https://$host$request_uri;
} # managed by Certbot
listen 80;
server_name dev.gargantext.org;
add_header Cache-Control "no-cache";
location '/.well-known/acme-challenge' {
root /var/www/gargantext;
}
# Always redirect to https
return 301 https://dev.gargantext.org$request_uri;
}
server {
listen 443;
listen [::]:443 ssl;
server_name dev.gargantext.org;
# Some options configurations:
# https://github.com/h5bp/server-configs-nginx/blob/master/h5bp/location/expires.conf
add_header Cache-Control "no-cache";
# SSL configuration
#
# listen 443 ssl default_server;
# listen [::]:443 ssl default_server;
ssl on;
ssl_certificate /etc/letsencrypt/live/dev.gargantext.org/fullchain.pem; # managed by Certbot
ssl_certificate_key /etc/letsencrypt/live/dev.gargantext.org/privkey.pem; # managed by Certbot
# Note: You should disable gzip for SSL traffic.
# See: https://bugs.debian.org/773332
#
# Read up on ssl_ciphers to ensure a secure configuration.
# See: https://bugs.debian.org/765782
#
# Self signed certs generated by the ssl-cert package
# Don't use them in a production server!
#
# include snippets/snakeoil.conf;
client_max_body_size 800M;
client_body_timeout 12;
client_header_timeout 12;
keepalive_timeout 15;
send_timeout 10;
root /var/www/html;
index index.html;
#add_header Access-Control-Allow-Origin $http_origin always;
# Add index.php to the list if you are using PHP
#index index.html index.htm index.nginx-debian.html;
# CORS config borrowed from: https://gist.github.com/pauloricardomg/7084524
# NP: not sure we need CORS yet
#
if ($http_origin ~* (^https?://(127.0.0.1|localhost|dev\.gargantext\.com))) {
set $cors "1";
}
#
# Cross-Origin Resource Sharing
if ($request_method = "OPTIONS") {
set $cors "${cors}o";
}
# SSL CERT renewal
location '/.well-known/acme-challenge' {
alias /var/www/gargantext/.well-known/acme-challenge ;
}
location /api {
# limit_except OPTIONS {
# auth_basic "Gargantext's Development Version";
# auth_basic_user_file /etc/nginx/haskell_gargantext.htpasswd;
# }
proxy_set_header X-Real-IP $remote_addr;
proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for;
proxy_set_header X-Forwarded-Proto $scheme;
proxy_set_header Host $http_host;
proxy_redirect off;
proxy_pass http://127.0.0.1:8008;
}
location / {
# https://stackoverflow.com/a/48708812
limit_except OPTIONS {
auth_basic "Gargantext's Development Version";
auth_basic_user_file /etc/nginx/haskell_gargantext.htpasswd;
}
proxy_set_header X-Real-IP $remote_addr;
proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for;
proxy_set_header X-Forwarded-Proto $scheme;
proxy_set_header Host $http_host;
proxy_redirect off;
proxy_pass http://127.0.0.1:8008;
}
#access_log off;
access_log /var/log/nginx/access.log;
error_log /var/log/nginx/error.log;
}
sudo apt install apache2-utils
htpasswd -c /etc/nginx/haskell_gargantext.htpasswd username1
sudo apt-get install certbot python-certbot-nginx
sudo certbot --nginx
......@@ -4,12 +4,12 @@
# postgresql://$USER:$PW@localhost/$DB
PW="password"
PW="C8kdcUrAQy66U"
DB="gargandbV5"
USER="gargantua"
psql -c "CREATE USER \"${USER}\""
psql -c "ALTER USER \"${USER}\" with PASSWORD \"${PW}\""
psql -c "ALTER USER \"${USER}\" with PASSWORD '${PW}'"
psql -c "DROP DATABASE IF EXISTS \"${DB}\""
createdb "${DB}"
......
CREATE EXTENSION IF NOT EXISTS plpgsql WITH SCHEMA pg_catalog;
CREATE EXTENSION IF NOT EXISTS tsm_system_rows;
COMMENT ON EXTENSION plpgsql IS 'PL/pgSQL procedural language';
-- CREATE USER WITH ...
-- createdb "gargandb"
CREATE TABLE public.auth_user (
id SERIAL,
password character varying(128) NOT NULL,
......@@ -23,7 +19,6 @@ CREATE TABLE public.auth_user (
ALTER TABLE public.auth_user OWNER TO gargantua;
-- TODO add publication_date
-- TODO typename -> type_id
CREATE TABLE public.nodes (
......@@ -40,7 +35,6 @@ CREATE TABLE public.nodes (
);
ALTER TABLE public.nodes OWNER TO gargantua;
CREATE TABLE public.ngrams (
id SERIAL,
terms character varying(255),
......@@ -50,22 +44,34 @@ CREATE TABLE public.ngrams (
ALTER TABLE public.ngrams OWNER TO gargantua;
--------------------------------------------------------------
-- TODO: delete delete this table
--CREATE TABLE public.nodes_ngrams (
-- id SERIAL,
-- node_id integer NOT NULL,
-- ngrams_id integer NOT NULL,
-- parent_id integer REFERENCES public.nodes_ngrams(id) ON DELETE SET NULL,
-- ngrams_type integer,
-- list_type integer,
-- weight double precision,
-- FOREIGN KEY (node_id) REFERENCES public.nodes(id) ON DELETE CASCADE,
-- FOREIGN KEY (ngrams_id) REFERENCES public.ngrams(id) ON DELETE CASCADE,
-- PRIMARY KEY (id)
--);
--ALTER TABLE public.nodes_ngrams OWNER TO gargantua;
--------------------------------------------------------------
CREATE TABLE public.node_ngrams (
id SERIAL,
node_id integer NOT NULL,
node_subtype integer,
ngrams_id integer NOT NULL,
ngrams_type integer, -- change to ngrams_field? (no for pedagogic reason)
ngrams_field integer,
ngrams_tag integer,
ngrams_class integer,
weight double precision,
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_ngrams OWNER TO gargantua;
CREATE TABLE public.node_ngrams_ngrams (
node_id integer NOT NULL,
node_ngrams1_id integer NOT NULL,
node_ngrams2_id integer NOT NULL,
FOREIGN KEY (node_id) REFERENCES public.nodes(id) ON DELETE CASCADE,
FOREIGN KEY (node_ngrams1_id) REFERENCES public.node_ngrams(id) ON DELETE CASCADE,
FOREIGN KEY (node_ngrams2_id) REFERENCES public.node_ngrams(id) ON DELETE CASCADE,
PRIMARY KEY (node_id, node_ngrams1_id, node_ngrams2_id)
);
ALTER TABLE public.node_ngrams_ngrams OWNER TO gargantua;
--------------------------------------------------------------
--------------------------------------------------------------
--
--
......@@ -78,7 +84,6 @@ ALTER TABLE public.ngrams OWNER TO gargantua;
--);
--
--ALTER TABLE public.nodes_ngrams_ngrams OWNER TO gargantua;
---------------------------------------------------------------
-- TODO nodes_nodes(node1_id int, node2_id int, edge_type int , weight real)
CREATE TABLE public.nodes_nodes (
......@@ -93,13 +98,15 @@ ALTER TABLE public.nodes_nodes OWNER TO gargantua;
---------------------------------------------------------------
-- TODO should reference "id" of nodes_nodes (instead of node1_id, node2_id)
CREATE TABLE public.node_node_ngrams (
id SERIAL,
node1_id INTEGER NOT NULL REFERENCES public.nodes (id) ON DELETE CASCADE,
-- here id to node_ngrams
node2_id INTEGER NOT NULL REFERENCES public.nodes (id) ON DELETE CASCADE,
ngrams_id INTEGER NOT NULL REFERENCES public.ngrams (id) ON DELETE CASCADE,
ngrams_type INTEGER,
--ngrams_tag INTEGER,
--ngrams_class INTEGER,
weight double precision,
PRIMARY KEY (id)
PRIMARY KEY (node1_id, node2_id, ngrams_id, ngrams_type)
);
ALTER TABLE public.node_node_ngrams OWNER TO gargantua;
--------------------------------------------------------------
......@@ -124,7 +131,6 @@ CREATE TABLE public.rights (
);
ALTER TABLE public.rights OWNER TO gargantua;
------------------------------------------------------------
-- INDEXES
......@@ -142,6 +148,7 @@ CREATE UNIQUE INDEX ON public.nodes USING btree (typename, parent_id, ((hyperdat
CREATE UNIQUE INDEX ON public.ngrams (terms); -- TEST GIN
CREATE INDEX ON public.ngrams USING btree (id, terms);
CREATE UNIQUE INDEX ON public.node_ngrams USING btree (node_id,node_subtype, ngrams_id);
CREATE INDEX ON public.nodes_nodes USING btree (node1_id, node2_id, category);
CREATE UNIQUE INDEX ON public.nodes_nodes USING btree (node1_id, node2_id);
......@@ -150,36 +157,10 @@ CREATE UNIQUE INDEX ON public.node_node_ngrams USING btree (node1_id, node2_id,
CREATE INDEX ON public.node_node_ngrams USING btree (node1_id, node2_id);
CREATE INDEX ON public.node_node_ngrams USING btree (ngrams_id, node2_id);
-- TRIGGERS
-- TODO user haskell-postgresql-simple to create this function
-- with rights typename
CREATE OR REPLACE FUNCTION public.search_update()
RETURNS trigger AS $$
begin
IF new.typename = 4 AND new.hyperdata @> '{"language_iso2":"EN"}' THEN
new.search := to_tsvector( 'english' , (new.hyperdata ->> 'title') || ' ' || (new.hyperdata ->> 'abstract'));
ELSIF new.typename = 4 AND new.hyperdata @> '{"language_iso2":"FR"}' THEN
new.search := to_tsvector( 'french' , (new.hyperdata ->> 'title') || ' ' || (new.hyperdata ->> 'abstract'));
ELSIF new.typename = 41 THEN
new.search := to_tsvector( 'french' , (new.hyperdata ->> 'prenom')
|| ' ' || (new.hyperdata ->> 'nom')
|| ' ' || (new.hyperdata ->> 'fonction')
);
ELSE
new.search := to_tsvector( 'english' , new.name);
END IF;
return new;
end
$$ LANGUAGE plpgsql;
ALTER FUNCTION public.search_update() OWNER TO gargantua;
CREATE TRIGGER search_update_trigger BEFORE INSERT OR UPDATE ON nodes FOR EACH ROW EXECUTE PROCEDURE search_update();
------------------------------------------------------------------------
-- Ngrams Full DB Extraction Optim
-- TODO remove hard parameter
-- TODO remove hard parameter and move elsewhere
CREATE OR REPLACE function node_pos(int, int) returns bigint
AS 'SELECT count(id) from nodes
WHERE id < $1
......@@ -190,8 +171,3 @@ CREATE OR REPLACE function node_pos(int, int) returns bigint
--drop index node_by_pos;
create index node_by_pos on nodes using btree(node_pos(id,typename));
-- Initialize index with already existing data
UPDATE nodes SET hyperdata = hyperdata;
name: gargantext
version: '4.0.0.6'
version: '0.0.0.4'
synopsis: Search, map, share
description: Please see README.md
category: Data
......@@ -39,6 +39,8 @@ library:
- Gargantext.Core.Types.Main
- Gargantext.Core.Utils.Prefix
- Gargantext.Database
- Gargantext.Database.Init
- Gargantext.Database.Config
- Gargantext.Database.Flow
- Gargantext.Database.Schema.Node
- Gargantext.Database.Tree
......
......@@ -47,7 +47,7 @@ module Gargantext.API.Ngrams
, NgramsStatePatch
, NgramsTablePatch
, NgramsElement
, NgramsElement(..)
, mkNgramsElement
, mergeNgramsElement
......@@ -60,6 +60,7 @@ module Gargantext.API.Ngrams
, Repo(..)
, r_version
, r_state
, r_history
, NgramsRepo
, NgramsRepoElement(..)
, saveRepo
......
......@@ -33,24 +33,28 @@ import qualified Data.Set as Set
type RootTerm = Text
-- TODO-ACCESS: We want to do the security check before entering here.
-- Add a static capability parameter would be nice.
-- Ideally this is the access to `repoVar` which needs to
-- be properly guarded.
getListNgrams :: RepoCmdM env err m
=> [ListId] -> NgramsType
-> m (Map Text NgramsRepoElement)
getListNgrams nodeIds ngramsType = do
v <- view repoVar
repo <- liftIO $ readMVar v
let
getRepo :: RepoCmdM env err m => m NgramsRepo
getRepo = do
v <- view repoVar
liftIO $ readMVar v
listNgramsFromRepo :: [ListId] -> NgramsType
-> NgramsRepo -> Map Text NgramsRepoElement
listNgramsFromRepo nodeIds ngramsType repo = ngrams
where
ngramsMap = repo ^. r_state . at ngramsType . _Just
ngrams = Map.unionsWith mergeNgramsElement
[ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
pure ngrams
-- TODO-ACCESS: We want to do the security check before entering here.
-- Add a static capability parameter would be nice.
-- Ideally this is the access to `repoVar` which needs to
-- be properly guarded.
getListNgrams :: RepoCmdM env err m
=> [ListId] -> NgramsType
-> m (Map Text NgramsRepoElement)
getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
getTermsWith :: (RepoCmdM env err m, Ord a)
=> (Text -> a ) -> [ListId]
......@@ -61,19 +65,19 @@ getTermsWith f ls ngt lt = Map.fromListWith (<>)
<$> Map.toList
<$> Map.filter (\f' -> (fst f') == lt)
<$> mapTermListRoot ls ngt
<$> getRepo
where
toTreeWith f'' (t, (_lt, maybeRoot)) = case maybeRoot of
Nothing -> (f'' t, [])
Just r -> (f'' r, map f'' [t])
mapTermListRoot :: RepoCmdM env err m
=> [ListId] -> NgramsType
-> m (Map Text (ListType, (Maybe Text)))
mapTermListRoot nodeIds ngramsType = do
ngrams <- getListNgrams nodeIds ngramsType
pure $ Map.fromList [ (t, (_nre_list nre, _nre_root nre))
| (t, nre) <- Map.toList ngrams
]
mapTermListRoot :: [ListId] -> NgramsType
-> NgramsRepo -> Map Text (ListType, (Maybe Text))
mapTermListRoot nodeIds ngramsType repo =
Map.fromList [ (t, (_nre_list nre, _nre_root nre))
| (t, nre) <- Map.toList ngrams
]
where ngrams = listNgramsFromRepo nodeIds ngramsType repo
filterListWithRoot :: ListType -> Map Text (ListType, Maybe Text)
-> Map Text (Maybe RootTerm)
......
......@@ -60,7 +60,7 @@ import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Facet (FacetDoc, OrderBy(..))
import Gargantext.Database.Node.Children (getChildren)
import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, getNode', deleteNode, deleteNodes, mkNodeWithParent, JSONB, HasNodeError(..))
import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNodeWith, getNode, deleteNode, deleteNodes, mkNodeWithParent, JSONB, HasNodeError(..))
import Gargantext.Database.Schema.NodeNode (nodeNodesCategory)
import Gargantext.Database.Tree (treeDB)
import Gargantext.Database.Types.Node
......@@ -169,7 +169,7 @@ nodeNodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> Corpu
nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uId (PathNodeNode cId nId) nodeNodeAPI'
where
nodeNodeAPI' :: GargServer (NodeNodeAPI a)
nodeNodeAPI' = getNode nId p
nodeNodeAPI' = getNodeWith nId p
......@@ -179,7 +179,7 @@ nodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> NodeId ->
nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
where
nodeAPI' :: GargServer (NodeAPI a)
nodeAPI' = getNode id p
nodeAPI' = getNodeWith id p
:<|> rename id
:<|> postNode uId id
:<|> putNode id
......@@ -205,7 +205,7 @@ nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode i
-- :<|> postUpload id
deleteNodeApi id' = do
node <- getNode' id'
node <- getNode id'
if _node_typename node == nodeTypeId NodeUser
then panic "not allowed" -- TODO add proper Right Management Type
else deleteNode id'
......@@ -337,7 +337,7 @@ rename nId (RenameNode name') = U.update (U.Rename nId name')
postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
postNode uId pId (PostNode nodeName nt) = do
nodeUser <- getNode (NodeId uId) HyperdataUser
nodeUser <- getNodeWith (NodeId uId) HyperdataUser
let uId' = nodeUser ^. node_userId
mkNodeWithParent nt (Just pId) uId' nodeName
......
......@@ -178,14 +178,18 @@ data MockEnv = MockEnv
makeLenses ''MockEnv
-- | TODO add this path in Settings
repoDir :: FilePath
repoDir = "repos"
repoSnapshot :: FilePath
repoSnapshot = "repo.json"
repoSnapshot = repoDir <> "/repo.json"
-- | TODO add hard coded file in Settings
-- This assumes we own the lock on repoSnapshot.
repoSaverAction :: ToJSON a => a -> IO ()
repoSaverAction a = do
withTempFile "." "tmp-repo.json" $ \fp h -> do
withTempFile "repos" "tmp-repo.json" $ \fp h -> do
-- printDebug "repoSaverAction" fp
L.hPut h $ encode a
hClose h
......@@ -210,6 +214,8 @@ mkRepoSaver repo_var = mkDebounce settings
readRepoEnv :: IO RepoEnv
readRepoEnv = do
-- Does file exist ? :: Bool
_repoDir <- createDirectoryIfMissing True repoDir
repoFile <- doesFileExist repoSnapshot
-- Is file not empty ? :: Bool
......@@ -230,7 +236,7 @@ readRepoEnv = do
pure repo
else
pure initRepo
-- TODO save in DB here
saver <- mkRepoSaver mvar
pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
......
......@@ -46,8 +46,6 @@ class HasText h
where
hasText :: h -> [Text]
------------------------------------------------------------------------
instance UniqId HyperdataDocument
where
uniqId = hyperdataDocument_uniqId
......@@ -56,4 +54,3 @@ instance UniqId HyperdataContact
where
uniqId = hc_uniqId
......@@ -57,14 +57,15 @@ nodeTypeId n =
---- Lists
NodeList -> 5
NodeListModel -> 10
NodeListCooc -> 50
NodeListModel -> 52
---- Scores
-- NodeOccurrences -> 10
NodeGraph -> 9
NodePhylo -> 90
NodeDashboard -> 7
NodeChart -> 51
NodeChart -> 7
NodeDashboard -> 71
NodeNoteBook -> 88
-- Cooccurrences -> 9
......@@ -96,7 +97,3 @@ fromNodeTypeId :: NodeTypeId -> NodeType
fromNodeTypeId tId = fromMaybe (panic $ pack $ "Type Id " <> show tId <> " does not exist")
(lookup tId nodeTypeInv)
......@@ -41,16 +41,12 @@ import Prelude (String)
import Data.Either
import Debug.Trace (trace)
import Control.Lens ((^.), view, _Just)
import Control.Monad (mapM_)
import Control.Monad.IO.Class (liftIO)
import Data.List (concat)
import Data.Map (Map, lookup, toList)
import Data.Map (Map, lookup)
import Data.Maybe (Maybe(..), catMaybes)
import Data.Monoid
import Data.Text (Text, splitOn, intercalate)
import GHC.Show (Show)
import Gargantext.API.Ngrams (HasRepoVar)
import Gargantext.API.Ngrams (NgramsElement, putListNgrams, RepoCmdM)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Types (NodePoly(..), Terms(..))
import Gargantext.Core.Types.Individu (Username)
......@@ -58,6 +54,8 @@ import Gargantext.Core.Flow
import Gargantext.Core.Types.Main
import Gargantext.Database.Config (userMaster, corpusMasterName)
import Gargantext.Database.Flow.Utils (insertDocNgrams)
import Gargantext.Database.Flow.List
import Gargantext.Database.Flow.Types
import Gargantext.Database.Node.Contact -- (HyperdataContact(..), ContactWho(..))
import Gargantext.Database.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
import Gargantext.Database.Root (getRoot)
......@@ -66,8 +64,7 @@ import Gargantext.Database.Schema.Node -- (mkRoot, mkCorpus, getOrMkList, mkGrap
import Gargantext.Database.Schema.User (getUser, UserLight(..))
import Gargantext.Database.TextSearch (searchInDatabase)
import Gargantext.Database.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
import Gargantext.Database.Utils (Cmd, CmdM)
import Gargantext.Database.Triggers
import Gargantext.Database.Utils (Cmd)
import Gargantext.Ext.IMT (toSchoolName)
import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
import Gargantext.Prelude
......@@ -85,13 +82,6 @@ import qualified Data.Text as Text
import qualified Gargantext.Database.Node.Document.Add as Doc (add)
import qualified Gargantext.Text.Corpus.Parsers.GrandDebat as GD
type FlowCmdM env err m =
( CmdM env err m
, RepoCmdM env err m
, HasNodeError err
, HasRepoVar env
)
------------------------------------------------------------------------
data ApiQuery = ApiIsidoreQuery Text | ApiIsidoreAuth Text
......@@ -221,20 +211,22 @@ flowCorpusUser :: (FlowCmdM env err m, MkCorpus c)
flowCorpusUser l userName corpusName ctype ids = do
-- User Flow
(userId, _rootId, userCorpusId) <- getOrMkRootWithCorpus userName corpusName ctype
listId <- getOrMkList userCorpusId userId
_cooc <- mkNode NodeListCooc listId userId
-- TODO: check if present already, ignore
_ <- Doc.add userCorpusId ids
tId <- mkNode NodeTexts userCorpusId userId
printDebug "Node Text Id" tId
_tId <- mkNode NodeTexts userCorpusId userId
-- printDebug "Node Text Id" tId
-- User List Flow
--{-
(masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster (Left "") ctype
(_masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster (Left "") ctype
ngs <- buildNgramsLists l 2 3 (StopSize 3) userCorpusId masterCorpusId
userListId <- flowList userId userCorpusId ngs
mastListId <- getOrMkList masterCorpusId masterUserId
_ <- insertOccsUpdates userCorpusId mastListId
printDebug "userListId" userListId
_userListId <- flowList listId ngs
--mastListId <- getOrMkList masterCorpusId masterUserId
-- _ <- insertOccsUpdates userCorpusId mastListId
-- printDebug "userListId" userListId
-- User Graph Flow
_ <- mkDashboard userCorpusId userId
_ <- mkGraph userCorpusId userId
......@@ -284,6 +276,7 @@ insertMasterDocs c lang hs = do
let indexedNgrams = Map.mapKeys (indexNgrams terms2id) maps
lId <- getOrMkList masterCorpusId masterUserId
_cooc <- mkNode NodeListCooc lId masterUserId
_ <- insertDocNgrams lId indexedNgrams
pure $ map reId ids
......@@ -351,15 +344,6 @@ toInserted =
Map.fromList . map (\r -> (reUniqId r, r) )
. filter (\r -> reInserted r == True)
data DocumentWithId a = DocumentWithId
{ documentId :: !NodeId
, documentData :: !a
} deriving (Show)
instance HasText a => HasText (DocumentWithId a)
where
hasText (DocumentWithId _ a) = hasText a
mergeData :: Map HashId ReturnId
-> Map HashId a
-> [DocumentWithId a]
......@@ -370,11 +354,6 @@ mergeData rs = catMaybes . map toDocumentWithId . Map.toList
<*> Just hpd
------------------------------------------------------------------------
data DocumentIdWithNgrams a = DocumentIdWithNgrams
{ documentWithId :: !(DocumentWithId a)
, document_ngrams :: !(Map Ngrams (Map NgramsType Int))
} deriving (Show)
instance HasText HyperdataContact
where
......@@ -452,37 +431,3 @@ documentIdWithNgrams f = mapM toDocumentIdWithNgrams
e <- f $ documentData d
pure $ DocumentIdWithNgrams d e
-- FLOW LIST
-- | TODO check optimization
mapNodeIdNgrams :: [DocumentIdWithNgrams a]
-> Map Ngrams (Map NgramsType (Map NodeId Int))
mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
where
f :: DocumentIdWithNgrams a
-> Map Ngrams (Map NgramsType (Map NodeId Int))
f d = fmap (fmap (Map.singleton nId)) $ document_ngrams d
where
nId = documentId $ documentWithId d
------------------------------------------------------------------------
listInsert :: FlowCmdM env err m
=> ListId
-> Map NgramsType [NgramsElement]
-> m ()
listInsert lId ngs = mapM_ (\(typeList, ngElmts)
-> putListNgrams lId typeList ngElmts
) $ toList ngs
flowList :: FlowCmdM env err m
=> UserId
-> CorpusId
-> Map NgramsType [NgramsElement]
-> m ListId
flowList uId cId ngs = do
lId <- getOrMkList cId uId
printDebug "listId flowList" lId
listInsert lId ngs
--trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
pure lId
{-|
Module : Gargantext.Database.Flow.List
Description : List Flow
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Database.Flow.List
where
import Control.Monad (mapM_)
import Data.Map (Map, toList)
import Data.Maybe (Maybe(..))
import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams)
import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams, NgramsType(..), text2ngrams, ngramsTypeId)
import Gargantext.Database.Schema.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb)
import Gargantext.Database.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
import Gargantext.Database.Flow.Types
import Gargantext.Prelude
import qualified Data.List as List
import qualified Data.Map as Map
-- FLOW LIST
-- | TODO check optimization
mapNodeIdNgrams :: [DocumentIdWithNgrams a]
-> Map Ngrams (Map NgramsType (Map NodeId Int))
mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
where
f :: DocumentIdWithNgrams a
-> Map Ngrams (Map NgramsType (Map NodeId Int))
f d = fmap (fmap (Map.singleton nId)) $ document_ngrams d
where
nId = documentId $ documentWithId d
------------------------------------------------------------------------
listInsert :: FlowCmdM env err m
=> ListId
-> Map NgramsType [NgramsElement]
-> m ()
listInsert lId ngs = mapM_ (\(typeList, ngElmts)
-> putListNgrams lId typeList ngElmts
) $ toList ngs
toNodeNgramsW :: ListId
-> [(NgramsType, [NgramsElement])]
-> [NodeNgramsW]
toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW' l) ngs
where
toNodeNgramsW' :: ListId
-> (NgramsType, [NgramsElement])
-> [NodeNgramsW]
toNodeNgramsW' l' (ngrams_type, elms) =
[ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
(NgramsElement ngrams_terms' _size list_type _occ _root _parent _children) <- elms
]
flowList :: FlowCmdM env err m
=> ListId
-> Map NgramsType [NgramsElement]
-> m ListId
flowList lId ngs = do
-- printDebug "listId flowList" lId
-- TODO save in database
_r <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
-- printDebug "result " r
listInsert lId ngs
--trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
pure lId
{-|
Module : Gargantext.Database.Flow.Types
Description : Types for Flow
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Database.Flow.Types
where
import Data.Map (Map)
import Gargantext.Prelude
import Gargantext.Core.Flow
import Gargantext.API.Ngrams (HasRepoVar, RepoCmdM)
import Gargantext.Database.Schema.Ngrams (Ngrams(..), NgramsType(..))
import Gargantext.Database.Types.Node (NodeId)
import Gargantext.Database.Schema.Node (HasNodeError)
import Gargantext.Database.Utils (CmdM)
type FlowCmdM env err m =
( CmdM env err m
, RepoCmdM env err m
, HasNodeError err
, HasRepoVar env
)
data DocumentIdWithNgrams a = DocumentIdWithNgrams
{ documentWithId :: !(DocumentWithId a)
, document_ngrams :: !(Map Ngrams (Map NgramsType Int))
} deriving (Show)
data DocumentWithId a = DocumentWithId
{ documentId :: !NodeId
, documentData :: !a
} deriving (Show)
instance HasText a => HasText (DocumentWithId a)
where
hasText (DocumentWithId _ a) = hasText a
......@@ -66,7 +66,7 @@ docNgrams2nodeNodeNgrams :: CorpusId
-> DocNgrams
-> NodeNodeNgrams
docNgrams2nodeNodeNgrams cId (DocNgrams d n nt w) =
NodeNodeNgrams Nothing cId d n nt w
NodeNodeNgrams cId d n nt w
data DocNgrams = DocNgrams { dn_doc_id :: DocId
, dn_ngrams_id :: Int
......
{-|
Module : Gargantext.Database.Init
Description : Triggers configuration
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Ngrams by node enable contextual metrics.
-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Init
where
-- import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Gargantext.Database.Utils (Cmd)
import Gargantext.Prelude
import Gargantext.Database.Triggers.Nodes (triggerSearchUpdate)
import Gargantext.Database.Triggers.NodesNodes (triggerDeleteCount, triggerInsertCount, triggerUpdateAdd, triggerUpdateDel, MasterListId)
import Gargantext.Database.Triggers.NodeNodeNgrams (triggerCountInsert)
------------------------------------------------------------------------
initTriggers :: MasterListId -> Cmd err [Int64]
initTriggers lId = do
t0 <- triggerSearchUpdate
t1 <- triggerCountInsert
t2 <- triggerDeleteCount lId
t3 <- triggerInsertCount lId
t4 <- triggerUpdateAdd lId
t5 <- triggerUpdateDel lId
pure [t0, t1,t2,t3,t4,t5]
......@@ -21,7 +21,7 @@ module Gargantext.Database.Metrics
import Data.Map (Map)
import Data.Text (Text)
import Gargantext.API.Ngrams (TabType(..), ngramsTypeFromTabType)
import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm)
import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo)
import Gargantext.Core.Types (ListType(..), Limit, NodeType(..))
import Gargantext.Database.Flow (FlowCmdM)
import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser{-, getTficfWith-})
......@@ -76,7 +76,7 @@ getNgrams cId maybeListId tabType = do
Nothing -> defaultList cId
Just lId' -> pure lId'
lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType)
lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo
let maybeSyn = Map.unions $ map (\t -> filterListWithRoot t lists)
[GraphTerm, StopTerm, CandidateTerm]
pure (lists, maybeSyn)
......
......@@ -279,8 +279,6 @@ queryNgramsOccurrencesOnlyByNodeUser' = [sql|
|]
getNodesByNgramsOnlyUser :: NodeId -> [ListId] -> NgramsType -> [Text]
-> Cmd err (Map Text (Set NodeId))
getNodesByNgramsOnlyUser cId ls nt ngs =
......
......@@ -281,6 +281,7 @@ nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id = optio
}
)
queryNodeSearchTable :: Query NodeSearchRead
queryNodeSearchTable = queryTable nodeTableSearch
......@@ -371,8 +372,13 @@ selectNodesWithType type_id = proc () -> do
type JSONB = QueryRunnerColumnDefault PGJsonb
getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
getNode nId _ = do
getNode :: NodeId -> Cmd err (Node Value)
getNode nId = fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
getNodeWith :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
getNodeWith nId _ = do
fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
......@@ -382,11 +388,6 @@ getNodePhylo nId = do
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
getNode' :: NodeId -> Cmd err (Node Value)
getNode' nId = fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
getNodesWithType = runOpaQuery . selectNodesWithType
......@@ -464,12 +465,14 @@ instance HasDefault NodeType where
hasDefaultData nt = case nt of
NodeTexts -> HyperdataTexts (Just "Preferences")
NodeList -> HyperdataList' (Just "Preferences")
NodeListCooc -> HyperdataList' (Just "Preferences")
_ -> undefined
--NodeAnnuaire -> HyperdataAnnuaire (Just "Title") (Just "Description")
hasDefaultName nt = case nt of
NodeTexts -> "Texts"
NodeList -> "Lists"
NodeListCooc -> "Cooc"
_ -> undefined
------------------------------------------------------------------------
......@@ -717,3 +720,4 @@ pgNodeId = pgInt4 . id2int
getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
{-|
Module : Gargantext.Database.Schema.NodeNgrams
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
NodeNgrams register Context of Ngrams (named Cgrams then)
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.NodeNgrams where
import Data.Text (Text)
import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Database.PostgreSQL.Simple.FromRow (fromRow, field)
import Database.PostgreSQL.Simple.ToField (toField)
import Database.PostgreSQL.Simple (FromRow)
import Database.PostgreSQL.Simple.SqlQQ (sql)
-- import Control.Lens.TH (makeLenses)
import Data.Maybe (Maybe, fromMaybe)
import Gargantext.Core.Types
import Gargantext.Database.Utils
import Gargantext.Database.Schema.Ngrams (NgramsType, ngramsTypeId)
import Gargantext.Prelude
data NodeNgramsPoly id
node_id'
node_subtype
ngrams_id
ngrams_type
ngrams_field
ngrams_tag
ngrams_class
weight
= NodeNgrams { _nng_id :: id
, _nng_node_id :: node_id'
, _nng_node_subtype :: node_subtype
, _nng_ngrams_id :: ngrams_id
, _nng_ngrams_type :: ngrams_type
, _nng_ngrams_field :: ngrams_field
, _nng_ngrams_tag :: ngrams_tag
, _nng_ngrams_class :: ngrams_class
, _nng_ngrams_weight :: weight
} deriving (Show)
{-
type NodeNgramsWrite = NodeNgramsPoly (Maybe (Column (PGInt4)))
(Column (PGInt4))
(Maybe (Column (PGInt4)))
(Column (PGInt4))
(Maybe (Column (PGInt4)))
(Maybe (Column (PGInt4)))
(Maybe (Column (PGInt4)))
(Maybe (Column (PGInt4)))
(Maybe (Column (PGFloat8)))
type NodeNodeRead = NodeNgramsPoly (Column PGInt4)
(Column PGInt4)
(Column PGInt4)
(Column PGInt4)
(Column PGInt4)
(Column PGInt4)
(Column PGInt4)
(Column PGInt4)
(Column PGFloat8)
type NodeNgramsReadNull = NodeNgramsPoly (Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGFloat8))
-}
type NgramsId = Int
type NgramsField = Int
type NgramsTag = Int
type NgramsClass = Int
type NgramsText = Text
-- Example of list Ngrams
-- type ListNgrams = NodeNgramsPoly (Maybe Int) ListType Text
type NodeNgramsW =
NodeNgramsPoly (Maybe Int) NodeId ListType NgramsText
NgramsType (Maybe NgramsField) (Maybe NgramsTag) (Maybe NgramsClass)
Double
data Returning = Returning { re_terms :: Text
, re_ngrams_id :: Int
}
deriving (Show)
instance FromRow Returning where
fromRow = Returning <$> field <*> field
-- insertDb :: ListId -> Map NgramsType [NgramsElemet] -> Cmd err [Result]
listInsertDb :: Show a => ListId
-> (ListId -> a -> [NodeNgramsW])
-> a
-> Cmd err [Returning]
listInsertDb l f ngs = insertNodeNgrams (f l ngs)
-- TODO optimize with size of ngrams
insertNodeNgrams :: [NodeNgramsW] -> Cmd err [Returning]
insertNodeNgrams nns = runPGSQuery query (PGS.Only $ Values fields nns')
where
fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"
,"int4","int4","int4","int4"
,"float8"]
-- nns' :: [(Int, ListTypeId, NgramsText, NgramsTypeId ,NgramsField, NgramsTag, NgramsClass, Double)]
nns' = map (\(NodeNgrams _id (NodeId node_id'') node_subtype ngrams_terms ngrams_type ngrams_field ngrams_tag ngrams_class weight)
-> [ toField node_id''
, toField $ listTypeId node_subtype
, toField $ ngrams_terms
, toField $ ngramsTypeId ngrams_type
, toField $ fromMaybe 0 ngrams_field
, toField $ fromMaybe 0 ngrams_tag
, toField $ fromMaybe 0 ngrams_class
, toField weight
]
) nns
query :: PGS.Query
query = [sql|
WITH input(node_id, node_subtype, ngrams_terms, ngrams_type, ngrams_field, ngrams_tag, ngrams_class, weight) AS (?),
return(id, ngrams_id) AS (
INSERT INTO node_ngrams (node_id, node_subtype, ngrams_id, ngrams_type, ngrams_field, ngrams_tag, ngrams_class, weight)
SELECT i.node_id, i.node_subtype, ng.id, i.ngrams_type, i.ngrams_field, i.ngrams_tag, i.ngrams_class, i.weight FROM input as i
INNER JOIN ngrams as ng ON ng.terms = i.ngrams_terms
ON CONFLICT(node_id, node_subtype, ngrams_id)
DO UPDATE SET node_subtype = excluded.node_subtype, ngrams_type = excluded.ngrams_type, ngrams_field = excluded.ngrams_field, ngrams_tag = excluded.ngrams_tag, ngrams_class = excluded.ngrams_class, weight = excluded.weight
RETURNING id, ngrams_id
)
SELECT ng.terms, return.id FROM return
INNER JOIN ngrams ng ON return.ngrams_id = ng.id;
|]
......@@ -120,12 +120,12 @@ nodeNodesCategory inputData = map (\(PGS.Only a) -> a)
where
fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","int4"]
catQuery :: PGS.Query
catQuery = [sql| UPDATE nodes_nodes as old SET
category = new.category
from (?) as new(node1_id,node2_id,category)
WHERE old.node1_id = new.node1_id
AND old.node2_id = new.node2_id
RETURNING new.node2_id
catQuery = [sql| UPDATE nodes_nodes as nn0
SET category = nn1.category
FROM (?) as nn1(node1_id,node2_id,category)
WHERE nn0.node1_id = nn1.node1_id
AND nn0.node2_id = nn1.node2_id
RETURNING nn1.node2_id
|]
------------------------------------------------------------------------
......@@ -187,12 +187,12 @@ nodesToTrash input = map (\(PGS.Only a) -> a)
where
fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","bool"]
trashQuery :: PGS.Query
trashQuery = [sql| UPDATE nodes_nodes as old SET
delete = new.delete
from (?) as new(node1_id,node2_id,delete)
WHERE old.node1_id = new.node1_id
AND old.node2_id = new.node2_id
RETURNING new.node2_id
trashQuery = [sql| UPDATE nodes_nodes as nn0 SET
delete = nn1.delete
from (?) as nn1(node1_id,node2_id,delete)
WHERE nn0.node1_id = nn1.node1_id
AND nn0.node2_id = nn1.node2_id
RETURNING nn1.node2_id
|]
-- | /!\ Really remove nodes in the Corpus or Annuaire
......
......@@ -23,7 +23,6 @@ module Gargantext.Database.Schema.NodeNodeNgrams
where
import Prelude
import Data.Maybe (Maybe)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Control.Lens.TH (makeLenses)
import Gargantext.Database.Utils (Cmd, mkCmd)
......@@ -33,10 +32,8 @@ import Gargantext.Database.Types.Node
import Opaleye
data NodeNodeNgramsPoly id' n1 n2 ngrams_id ngt w
= NodeNodeNgrams { _nnng_id :: id'
, _nnng_node1_id :: n1
data NodeNodeNgramsPoly n1 n2 ngrams_id ngt w
= NodeNodeNgrams { _nnng_node1_id :: n1
, _nnng_node2_id :: n2
, _nnng_ngrams_id :: ngrams_id
, _nnng_ngramsType :: ngt
......@@ -45,8 +42,7 @@ data NodeNodeNgramsPoly id' n1 n2 ngrams_id ngt w
type NodeNodeNgramsWrite =
NodeNodeNgramsPoly (Maybe (Column PGInt4 ))
(Column PGInt4 )
NodeNodeNgramsPoly (Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
......@@ -57,7 +53,6 @@ type NodeNodeNgramsRead =
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGFloat8)
type NodeNodeNgramsReadNull =
......@@ -65,11 +60,10 @@ type NodeNodeNgramsReadNull =
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGFloat8))
type NodeNodeNgrams =
NodeNodeNgramsPoly (Maybe Int) CorpusId DocId NgramsId NgramsTypeId Double
NodeNodeNgramsPoly CorpusId DocId NgramsId NgramsTypeId Double
$(makeAdaptorAndInstance "pNodeNodeNgrams" ''NodeNodeNgramsPoly)
makeLenses ''NodeNodeNgramsPoly
......@@ -78,8 +72,7 @@ makeLenses ''NodeNodeNgramsPoly
nodeNodeNgramsTable :: Table NodeNodeNgramsWrite NodeNodeNgramsRead
nodeNodeNgramsTable = Table "node_node_ngrams"
( pNodeNodeNgrams NodeNodeNgrams
{ _nnng_id = optional "id"
, _nnng_node1_id = required "node1_id"
{ _nnng_node1_id = required "node1_id"
, _nnng_node2_id = required "node2_id"
, _nnng_ngrams_id = required "ngrams_id"
, _nnng_ngramsType = required "ngrams_type"
......@@ -94,9 +87,8 @@ queryNodeNodeNgramsTable = queryTable nodeNodeNgramsTable
-- | Insert utils
insertNodeNodeNgrams :: [NodeNodeNgrams] -> Cmd err Int
insertNodeNodeNgrams = insertNodeNodeNgramsW
. map (\(NodeNodeNgrams id'' n1 n2 ng nt w) ->
NodeNodeNgrams (pgInt4 <$> id'')
(pgNodeId n1)
. map (\(NodeNodeNgrams n1 n2 ng nt w) ->
NodeNodeNgrams (pgNodeId n1)
(pgNodeId n2)
(pgInt4 ng)
(pgNgramsTypeId nt)
......
{-|
Module : Gargantext.Database.Schema.NodeNgramsNgrams
Module : Gargantext.Database.Schema.Node_NodeNgrams_NodeNgrams
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -7,10 +7,13 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
NodeNgramsNgrams table is used to group Ngrams
- NodeId :: List Id
- NgramId_1, NgramId_2 where all NgramId_2 will be added to NgramId_1
- weight: probability of the relation (TODO, fixed to 1 for simple stemming)
lgrams: listed ngrams
Node_NodeNgrams_NodeNgrams table is used to group ngrams
- first NodeId :: Referential / space node (corpus)
- NodeNgrams where Node is List
- lgrams1_id, lgrams2_id where all lgrams2_id will be added to lgrams1_id
- weight: score the relation
Next Step benchmark:
- recursive queries of postgres
......@@ -29,69 +32,68 @@ Next Step benchmark:
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Database.Schema.NodeNgramsNgrams
module Gargantext.Database.Schema.Node_NodeNgramsNodeNgrams
where
import Control.Lens (view)
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (Maybe)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Gargantext.Database.Utils (Cmd, runOpaQuery, connection)
import Gargantext.Database.Types.Node (ListId)
import Gargantext.Database.Utils (Cmd, runOpaQuery, mkCmd)
import Gargantext.Database.Types.Node (CorpusId)
import Gargantext.Database.Schema.Node (pgNodeId)
import Gargantext.Prelude
import Opaleye
data NodeNgramsNgramsPoly node_id ngram1_id ngram2_id weight =
NodeNgramsNgrams { _nng_NodeId :: node_id
, _nng_Ngram1Id :: ngram1_id
, _nng_Ngram2Id :: ngram2_id
, _nng_Weight :: weight
} deriving (Show)
type NodeNgramsNgramsWrite =
NodeNgramsNgramsPoly (Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Maybe (Column PGFloat8))
type NodeNgramsNgramsRead =
NodeNgramsNgramsPoly (Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGFloat8)
type NodeNgramsNgrams =
NodeNgramsNgramsPoly ListId
Int
Int
(Maybe Double)
$(makeAdaptorAndInstance "pNodeNgramsNgrams"
''NodeNgramsNgramsPoly)
data Node_NodeNgrams_NodeNgrams_Poly node_id nng1_id nng2_id weight =
Node_NodeNgrams_NodeNgrams { _nnn_node_id :: node_id
, _nnn_nng1_id :: nng1_id
, _nnn_nng2_id :: nng2_id
, _nnn_weight :: weight
} deriving (Show)
type Node_NodeNgrams_NodeNgrams_Write =
Node_NodeNgrams_NodeNgrams_Poly
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Maybe (Column PGFloat8))
type Node_NodeNgrams_NodeNgrams_Read =
Node_NodeNgrams_NodeNgrams_Poly
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column PGFloat8)
type ListNgramsId = Int
type Node_NodeNgrams_NodeNgrams =
Node_NodeNgrams_NodeNgrams_Poly CorpusId ListNgramsId ListNgramsId (Maybe Double)
$(makeAdaptorAndInstance "pNode_NodeNgrams_NodeNgrams"
''Node_NodeNgrams_NodeNgrams_Poly)
$(makeLensesWith abbreviatedFields
''NodeNgramsNgramsPoly)
''Node_NodeNgrams_NodeNgrams_Poly)
nodeNgramsNgramsTable :: Table NodeNgramsNgramsWrite NodeNgramsNgramsRead
nodeNgramsNgramsTable =
Table "nodes_ngrams_ngrams"
( pNodeNgramsNgrams NodeNgramsNgrams
{ _nng_NodeId = required "node_id"
, _nng_Ngram1Id = required "ngram1_id"
, _nng_Ngram2Id = required "ngram2_id"
, _nng_Weight = optional "weight"
node_NodeNgrams_NodeNgrams_Table :: Table Node_NodeNgrams_NodeNgrams_Write Node_NodeNgrams_NodeNgrams_Read
node_NodeNgrams_NodeNgrams_Table =
Table "nodes_nodengrams_nodengrams"
( pNode_NodeNgrams_NodeNgrams Node_NodeNgrams_NodeNgrams
{ _nnn_node_id = required "node_id"
, _nnn_nng1_id = required "nng1_id"
, _nnn_nng2_id = required "nng2_id"
, _nnn_weight = optional "weight"
}
)
queryNodeNgramsNgramsTable :: Query NodeNgramsNgramsRead
queryNodeNgramsNgramsTable = queryTable nodeNgramsNgramsTable
queryNode_NodeNgrams_NodeNgrams_Table :: Query Node_NodeNgrams_NodeNgrams_Read
queryNode_NodeNgrams_NodeNgrams_Table = queryTable node_NodeNgrams_NodeNgrams_Table
-- | Select NodeNgramsNgrams
-- TODO not optimized (get all ngrams without filters)
nodeNgramsNgrams :: Cmd err [NodeNgramsNgrams]
nodeNgramsNgrams = runOpaQuery queryNodeNgramsNgramsTable
node_Node_NodeNgrams_NodeNgrams :: Cmd err [Node_NodeNgrams_NodeNgrams]
node_Node_NodeNgrams_NodeNgrams = runOpaQuery queryNode_NodeNgrams_NodeNgrams_Table
instance QueryRunnerColumnDefault PGInt4 (Maybe Int) where
queryRunnerColumnDefault = fieldQueryRunnerColumn
......@@ -101,17 +103,19 @@ instance QueryRunnerColumnDefault PGFloat8 (Maybe Double) where
-- TODO: Add option on conflict
insertNodeNgramsNgramsNew :: [NodeNgramsNgrams] -> Cmd err Int
insertNodeNgramsNgramsNew = insertNodeNgramsNgramsW
. map (\(NodeNgramsNgrams n ng1 ng2 maybeWeight) ->
NodeNgramsNgrams (pgNodeId n )
insert_Node_NodeNgrams_NodeNgrams :: [Node_NodeNgrams_NodeNgrams] -> Cmd err Int64
insert_Node_NodeNgrams_NodeNgrams = insert_Node_NodeNgrams_NodeNgrams_W
. map (\(Node_NodeNgrams_NodeNgrams n ng1 ng2 maybeWeight) ->
Node_NodeNgrams_NodeNgrams (pgNodeId n )
(pgInt4 ng1)
(pgInt4 ng2)
(pgDouble <$> maybeWeight)
)
insertNodeNgramsNgramsW :: [NodeNgramsNgramsWrite] -> Cmd err Int
insertNodeNgramsNgramsW ns = do
c <- view connection
liftIO $ fromIntegral <$> runInsertMany c nodeNgramsNgramsTable ns
insert_Node_NodeNgrams_NodeNgrams_W :: [Node_NodeNgrams_NodeNgrams_Write] -> Cmd err Int64
insert_Node_NodeNgrams_NodeNgrams_W ns =
mkCmd $ \c -> runInsert_ c Insert { iTable = node_NodeNgrams_NodeNgrams_Table
, iRows = ns
, iReturning = rCount
, iOnConflict = (Just DoNothing)
}
{-|
Module : Gargantext.Database.Triggers
Description : Triggers configuration
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Ngrams by node enable contextual metrics.
-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Triggers
where
import Database.PostgreSQL.Simple.SqlQQ (sql)
-- import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Utils (Cmd, runPGSQuery)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
------------------------------------------------------------------------
type MasterListId = ListId
insertOccsUpdates :: UserCorpusId -> MasterListId -> Cmd err [DPS.Only Int]
insertOccsUpdates cId lId = runPGSQuery query (cId, lId, nodeTypeId NodeList, nodeTypeId NodeDocument)
where
query :: DPS.Query
query = [sql|
INSERT INTO node_node_ngrams (node1_id, node2_id, ngrams_id, ngrams_type, weight)
SELECT nn.node1_id, lists.id, nnn.ngrams_id, 1, count(*) as c -- type of score
FROM node_node_ngrams nnn
INNER JOIN nodes_nodes nn ON nn.node2_id = nnn.node2_id
INNER JOIN nodes docs ON docs.id = nnn.node2_id
INNER JOIN nodes lists ON lists.parent_id = nn.node1_id
-- WHERE nn.node1_id = NEW.node1_id -- .node1_id -- corpus_id
WHERE nn.node1_id = ? -- .node1_id -- corpus_id
AND nnn.node1_id in (?, lists.id) -- (masterList_id, userLists)
AND lists.typename = ?
AND docs.typename = ?
GROUP BY nn.node1_id, lists.id, nnn.ngrams_id
ON CONFLICT (node1_id, node2_id, ngrams_id, ngrams_type)
DO UPDATE SET weight = 3 -- c -- excluded.weight
RETURNING 1
-- TOCHECK
|]
triggerOccsUpdates :: CorpusId -> ListId -> Cmd err [DPS.Only Int]
triggerOccsUpdates cId lId = runPGSQuery query (cId, lId, nodeTypeId NodeList, nodeTypeId NodeDocument)
where
query :: DPS.Query
query = [sql|
drop trigger trigger_occs on nodes_nodes;
CREATE OR REPLACE FUNCTION occs_update() RETURNS trigger AS
$$
BEGIN
IF TG_OP = 'UPDATE' THEN
INSERT INTO node_node_ngrams (node1_id, node2_id, ngrams_id, ngrams_type, weight)
-- TODO edge_type instead of ngrams_type
SELECT nn.node1_id, lists.id, nnn.ngrams_id, count(*), 1 -- type of score
FROM node_node_ngrams nnn
INNER JOIN nodes_nodes nn ON nn.node2_id = nnn.node2_id
INNER JOIN nodes docs ON docs.id = nnn.node2_id
INNER JOIN nodes lists ON lists.parent_id = nn.node1_id
-- WHERE nn.node1_id = NEW.node1_id -- .node1_id -- corpus_id
WHERE nn.node1_id = ? -- .node1_id -- corpus_id
AND nnn.node1_id in (?, lists.id) -- (masterList_id, userLists)
AND lists.typename = ?
AND docs.typename = ?
GROUP BY nn.node1_id, lists.id, nnn.ngrams_id
ON CONFLICT (node1_id, node2_id, ngrams_id, ngrams_type)
DO UPDATE SET weight = excluded.weight;
END IF;
RETURN NULL;
END $$
LANGUAGE plpgsql;
CREATE TRIGGER trigger_occs
AFTER UPDATE ON nodes_nodes
REFERENCING NEW TABLE AS NEW
FOR EACH STATEMENT
EXECUTE PROCEDURE occs_update();
update nodes_nodes SET node1_id = node1_id;
|]
{-|
Module : Gargantext.Database.Triggers.NodeNodeNgrams
Description : Triggers configuration
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Triggers on NodeNodeNgrams table.
-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Triggers.NodeNodeNgrams
where
import Database.PostgreSQL.Simple.SqlQQ (sql)
-- import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Utils (Cmd, execPGSQuery)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
triggerCountInsert :: Cmd err Int64
triggerCountInsert = execPGSQuery query (nodeTypeId NodeDocument, nodeTypeId NodeList)
where
query :: DPS.Query
query = [sql|
CREATE OR REPLACE FUNCTION set_ngrams_global_count() RETURNS trigger AS $$
BEGIN
IF pg_trigger_depth() <> 1 THEN
RETURN NEW;
END IF;
IF TG_OP = 'INSERT' THEN
INSERT INTO node_node_ngrams (node1_id, node2_id, ngrams_id, ngrams_type, weight)
select n.parent_id, n.id, new1.ngrams_id, new1.ngrams_type, count(*) from NEW as new1
INNER JOIN nodes n ON n.id = new1.node1_id
INNER JOIN nodes n2 ON n2.id = new1.node2_id
WHERE n2.typename = ? -- not mandatory
AND n.typename = ? -- not mandatory
AND n.parent_id <> n2.id -- not mandatory
GROUP BY n.parent_id, n.id, new1.ngrams_id, new1.ngrams_type
ON CONFLICT (node1_id, node2_id, ngrams_id, ngrams_type)
DO UPDATE set weight = node_node_ngrams.weight + excluded.weight
;
END IF;
RETURN NULL;
END
$$ LANGUAGE plpgsql;
-- DROP trigger trigger_count_insert on node_node_ngrams;
CREATE TRIGGER trigger_count_insert AFTER INSERT on node_node_ngrams
REFERENCING NEW TABLE AS NEW
FOR EACH STATEMENT
EXECUTE PROCEDURE set_ngrams_global_count();
|]
{-|
Module : Gargantext.Database.Triggers.Nodes
Description : Triggers configuration
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Triggers on Nodes table.
-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Triggers.Nodes
where
import Database.PostgreSQL.Simple.SqlQQ (sql)
-- import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Utils (Cmd, execPGSQuery)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
triggerSearchUpdate :: Cmd err Int64
triggerSearchUpdate = execPGSQuery query ( nodeTypeId NodeDocument
, nodeTypeId NodeDocument
, nodeTypeId NodeContact
)
where
query :: DPS.Query
query = [sql|
CREATE OR REPLACE FUNCTION public.search_update()
RETURNS trigger AS $$
begin
IF new.typename = ? AND new.hyperdata @> '{"language_iso2":"EN"}' THEN
new.search := to_tsvector( 'english' , (new.hyperdata ->> 'title') || ' ' || (new.hyperdata ->> 'abstract'));
ELSIF new.typename = ? AND new.hyperdata @> '{"language_iso2":"FR"}' THEN
new.search := to_tsvector( 'french' , (new.hyperdata ->> 'title') || ' ' || (new.hyperdata ->> 'abstract'));
ELSIF new.typename = ? THEN
new.search := to_tsvector( 'french' , (new.hyperdata ->> 'prenom')
|| ' ' || (new.hyperdata ->> 'nom')
|| ' ' || (new.hyperdata ->> 'fonction')
);
ELSE
new.search := to_tsvector( 'english' , new.name);
END IF;
return new;
end
$$ LANGUAGE plpgsql;
ALTER FUNCTION public.search_update() OWNER TO gargantua;
CREATE TRIGGER search_update_trigger
BEFORE INSERT OR UPDATE
ON nodes FOR EACH ROW
EXECUTE PROCEDURE search_update();
-- Initialize index with already existing data
UPDATE nodes SET hyperdata = hyperdata;
|]
{-|
Module : Gargantext.Database.Triggers.NodesNodes
Description : Triggers configuration
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Triggers on NodesNodes table.
-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Triggers.NodesNodes
where
import Database.PostgreSQL.Simple.SqlQQ (sql)
-- import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Utils (Cmd, execPGSQuery)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS
type MasterListId = ListId
triggerDeleteCount :: MasterListId -> Cmd err Int64
triggerDeleteCount lId = execPGSQuery query (lId, nodeTypeId NodeList)
where
query :: DPS.Query
query = [sql|
CREATE OR REPLACE FUNCTION set_delete_count() RETURNS trigger AS $$
BEGIN
UPDATE node_node_ngrams SET weight = weight - d.delete_count
FROM (SELECT old1.node1_id as node1_id, lists.id as node2_id, nnn.ngrams_id as ngrams_id, nnn.ngrams_type as ngrams_type, count(*) as delete_count FROM OLD as old1
INNER JOIN nodes doc ON doc.id = old1.node2_id
INNER JOIN nodes lists ON lists.parent_id = old1.node1_id
INNER JOIN node_node_ngrams nnn ON nnn.node2_id = doc.id
WHERE nnn.node1_id in (?, lists.id)
AND lists.typename = ?
GROUP BY old1.node1_id, lists.id, nnn.ngrams_id, nnn.ngrams_type
) AS d
WHERE node_node_ngrams.node1_id = d.node1_id
AND node_node_ngrams.node2_id = d.node2_id
AND node_node_ngrams.ngrams_id = d.ngrams_id
AND node_node_ngrams.ngrams_type = d.ngrams_type
;
RETURN NULL;
END
$$ LANGUAGE plpgsql;
-- DROP trigger trigger_delete_count on nodes_nodes;
CREATE TRIGGER trigger_delete_count AFTER DELETE on nodes_nodes
REFERENCING OLD TABLE AS OLD
FOR EACH STATEMENT
EXECUTE PROCEDURE set_delete_count();
|]
triggerInsertCount :: MasterListId -> Cmd err Int64
triggerInsertCount lId = execPGSQuery query (lId, nodeTypeId NodeList)
where
query :: DPS.Query
query = [sql|
CREATE OR REPLACE FUNCTION set_insert_count() RETURNS trigger AS $$
BEGIN
INSERT INTO node_node_ngrams (node1_id, node2_id, ngrams_id, ngrams_type, weight)
SELECT new1.node1_id , lists.id, nnn.ngrams_id, nnn.ngrams_type, count(*) as weight from NEW as new1
INNER JOIN nodes doc ON doc.id = new1.node2_id
INNER JOIN nodes lists ON lists.parent_id = new1.node1_id
INNER JOIN node_node_ngrams nnn ON nnn.node2_id = doc.id
WHERE nnn.node1_id in (?, lists.id)
AND lists.typename = ?
GROUP BY new1.node1_id, lists.id, nnn.ngrams_id, nnn.ngrams_type
ON CONFLICT (node1_id, node2_id, ngrams_id, ngrams_type)
DO UPDATE set weight = node_node_ngrams.weight + excluded.weight
;
RETURN NULL;
END
$$ LANGUAGE plpgsql;
-- DROP trigger trigger_insert_count on nodes_nodes;
CREATE TRIGGER trigger_insert_count AFTER INSERT on nodes_nodes
REFERENCING NEW TABLE AS NEW
FOR EACH STATEMENT
EXECUTE PROCEDURE set_insert_count();
|]
triggerUpdateAdd :: MasterListId -> Cmd err Int64
triggerUpdateAdd lId = execPGSQuery query (lId, nodeTypeId NodeList)
where
query :: DPS.Query
query = [sql|
CREATE OR REPLACE FUNCTION set_update_ngrams_add() RETURNS trigger AS $$
BEGIN
UPDATE node_node_ngrams nnn0 SET weight = weight + d.fix_count
FROM (SELECT new1.node1_id as node1_id, lists.id as node2_id, nnn.ngrams_id as ngrams_id, nnn.ngrams_type as ngrams_type, count(*) as fix_count
FROM NEW as new1
INNER JOIN nodes lists ON new1.node1_id = lists.parent_id
INNER JOIN node_node_ngrams nnn ON new1.node2_id = nnn.node2_id
WHERE nnn.node1_id in (?, lists.id) -- (masterList_id, userLists)
AND lists.typename = ?
GROUP BY new1.node1_id, lists.id, nnn.ngrams_id, nnn.ngrams_type
) as d
WHERE nnn0.node1_id = d.node1_id
AND nnn0.node2_id = d.node2_id
AND nnn0.ngrams_id = d.ngrams_id
AND nnn0.ngrams_type = d.ngrams_type
;
RETURN NULL;
END
$$ LANGUAGE plpgsql;
-- DROP trigger trigger_count_update_add on nodes_nodes;
CREATE TRIGGER trigger_count_update_add AFTER UPDATE on nodes_nodes
REFERENCING OLD TABLE AS OLD NEW TABLE AS NEW
FOR EACH ROW
WHEN (OLD.category <= 0 AND NEW.category >= 1)
EXECUTE PROCEDURE set_update_ngrams_add();
|]
triggerUpdateDel :: MasterListId -> Cmd err Int64
triggerUpdateDel lId = execPGSQuery query (lId, nodeTypeId NodeList)
where
query :: DPS.Query
query = [sql|
CREATE OR REPLACE FUNCTION set_update_ngrams_count_del() RETURNS trigger AS $$
BEGIN
UPDATE node_node_ngrams nnn0 SET weight = weight - d.fix_count
FROM (SELECT new1.node1_id as node1_id, lists.id as node2_id, nnn.ngrams_id as ngrams_id, nnn.ngrams_type as ngrams_type, count(*) as fix_count
FROM NEW as new1
INNER JOIN nodes lists ON new1.node1_id = lists.parent_id
INNER JOIN node_node_ngrams nnn ON new1.node2_id = nnn.node2_id
WHERE nnn.node1_id in (?, lists.id) -- (masterList_id, userLists)
AND lists.typename = ?
GROUP BY new1.node1_id, lists.id, nnn.ngrams_id, nnn.ngrams_type
) as d
WHERE nnn0.node1_id = d.node1_id
AND nnn0.node2_id = d.node2_id
AND nnn0.ngrams_id = d.ngrams_id
AND nnn0.ngrams_type = d.ngrams_type
;
RETURN NULL;
END
$$ LANGUAGE plpgsql;
-- DROP trigger trigger_count_delete2 on nodes_nodes;
CREATE TRIGGER trigger_count_delete2 AFTER UPDATE on nodes_nodes
REFERENCING OLD TABLE AS OLD NEW TABLE AS NEW
FOR EACH ROW
WHEN (OLD.category >= 1 AND NEW.category <= 0)
EXECUTE PROCEDURE set_update_ngrams_count_del();
|]
......@@ -444,6 +444,7 @@ data NodeType = NodeUser
| NodeGraph | NodePhylo
| NodeDashboard | NodeChart | NodeNoteBook
| NodeList | NodeListModel
| NodeListCooc
deriving (Show, Read, Eq, Generic, Bounded, Enum)
......
......@@ -17,7 +17,7 @@ module Gargantext.Text.List
where
import Data.Either (partitionEithers, Either(..))
import Debug.Trace (trace)
-- import Debug.Trace (trace)
import Data.Map (Map)
import Data.Set (Set)
import Data.Text (Text)
......@@ -161,7 +161,7 @@ toList stop l n = case stop n of
toTermList :: Int -> Int -> (a -> Bool) -> [a] -> [(ListType, a)]
toTermList _ _ _ [] = []
toTermList a b stop ns = trace ("computing toTermList") $
toTermList a b stop ns = -- trace ("computing toTermList") $
map (toList stop CandidateTerm) xs
<> map (toList stop GraphTerm) ys
<> toTermList a b stop zs
......
......@@ -72,7 +72,7 @@ pieData :: FlowCmdM env err m
pieData cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId
ts <- mapTermListRoot ls nt
ts <- mapTermListRoot ls nt <$> getRepo
let
dico = filterListWithRoot lt ts
terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ Map.toList dico
......@@ -94,7 +94,7 @@ treeData :: FlowCmdM env err m
treeData cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId
ts <- mapTermListRoot ls nt
ts <- mapTermListRoot ls nt <$> getRepo
let
dico = filterListWithRoot lt ts
......@@ -112,7 +112,7 @@ treeData' :: FlowCmdM env ServerError m
treeData' cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId
ts <- mapTermListRoot ls nt
ts <- mapTermListRoot ls nt <$> getRepo
let
dico = filterListWithRoot lt ts
......
......@@ -83,12 +83,24 @@ instance ToSchema LegendField where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
makeLenses ''LegendField
---------------------------------------------------------------
type Version = Int
data ListForGraph = ListForGraph { _lfg_listId :: ListId
, _lfg_version :: Version
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_lfg_") ''ListForGraph)
instance ToSchema ListForGraph where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lfg_")
makeLenses ''ListForGraph
--
data GraphMetadata = GraphMetadata { _gm_title :: Text -- title of the graph
, _gm_corpusId :: [NodeId] -- we can map with different corpus
, _gm_legend :: [LegendField] -- legend of the Graph
, _gm_listId :: ListId
, _gm_version :: Int
, _gm_legend :: [LegendField] -- legend of the Graph
, _gm_list :: ListForGraph
-- , _gm_version :: Int
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
......
......@@ -24,10 +24,11 @@ Portability : POSIX
module Gargantext.Viz.Graph.API
where
import Debug.Trace (trace)
import Control.Lens (set, (^.), _Just, (^?))
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (Maybe(..))
import Gargantext.API.Ngrams (currentVersion)
import Gargantext.API.Ngrams (NgramsRepo, r_version)
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Types
import Gargantext.Core.Types.Main
......@@ -35,9 +36,10 @@ import Gargantext.Database.Config
import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Node.Select
import Gargantext.Database.Schema.Node (getNode, defaultList, insertGraph)
import Gargantext.Database.Schema.Node (getNodeWith, defaultList, insertGraph, HasNodeError)
import Gargantext.Database.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Utils (Cmd)
import Gargantext.Prelude
import Gargantext.Viz.Graph
import Gargantext.Viz.Graph.Tools -- (cooc2graph)
......@@ -62,49 +64,53 @@ graphAPI u n = getGraph u n
getGraph :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
getGraph uId nId = do
nodeGraph <- getNode nId HyperdataGraph
nodeGraph <- getNodeWith nId HyperdataGraph
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let graphVersion = graph ^? _Just
let listVersion = graph ^? _Just
. graph_metadata
. _Just
. gm_version
. gm_list
. lfg_version
v <- currentVersion
nodeUser <- getNode (NodeId uId) HyperdataUser
repo <- getRepo
let v = repo ^. r_version
nodeUser <- getNodeWith (NodeId uId) HyperdataUser
let uId' = nodeUser ^. node_userId
let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
identity
$ nodeGraph ^. node_parentId
case graph of
g <- case graph of
Nothing -> do
graph' <- computeGraph cId NgramsTerms v
graph' <- computeGraph cId NgramsTerms repo
_ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
pure graph'
Just graph' -> if graphVersion == Just v
Just graph' -> if listVersion == Just v
then pure graph'
else do
graph'' <- computeGraph cId NgramsTerms v
graph'' <- computeGraph cId NgramsTerms repo
_ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
pure graph''
pure $ trace ("salut" <> show g) $ g
-- TODO use Database Monad only here ?
computeGraph :: CorpusId -> NgramsType -> Int -> GargServer (Get '[JSON] Graph)
computeGraph cId nt v = do
computeGraph :: HasNodeError err => CorpusId -> NgramsType -> NgramsRepo -> Cmd err Graph
computeGraph cId nt repo = do
lId <- defaultList cId
let metadata = GraphMetadata "Title" [cId]
[ LegendField 1 "#FFF" "Cluster"
, LegendField 2 "#FFF" "Cluster"
]
lId
v
(ListForGraph lId (repo ^. r_version))
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
lIds <- selectNodesWithUsername NodeList userMaster
ngs <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] nt
let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
myCooc <- Map.filter (>1)
<$> getCoocByNgrams (Diagonal True)
......
......@@ -74,8 +74,8 @@ data ClustersParams = ClustersParams { bridgness :: Double
clustersParams :: Int -> ClustersParams
clustersParams x = ClustersParams (fromIntegral x) y
where
y | x < 100 = "0.0001"
| x < 350 = "0.001"
y | x < 100 = "0.01"
| x < 350 = "0.01"
| x < 500 = "0.01"
| x < 1000 = "0.1"
| otherwise = "1"
......
......@@ -4,7 +4,6 @@ extra-package-dbs: []
packages:
- .
docker:
enable: false
repo: 'fpco/stack-build:lts-14.6-garg'
......@@ -40,7 +39,7 @@ extra-deps:
- git: https://github.com/np/servant-job.git
commit: 8557bfc9472a1b2be0b7bc632c23701ba5f44bf8
- git: https://gitlab.iscpif.fr/gargantext/clustering-louvain.git
commit: b29040ce741629d61cc63e8ba97e75bf0944979e
commit: e5814cbfa71f43b0a453efb65f476240d7d51a53
- git: https://github.com/np/patches-map
commit: 8c6f38c4844ead53e664cf9c82ba461715dbe445
- git: https://github.com/delanoe/haskell-opaleye.git #- opaleye-0.6.7002.0
......
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