Skip to content

haskell-gargantext
haskell-gargantext
Commit 254e5d36 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[FEAT] Annuaire <-> Corpus pairing (WIP)

parent d435ae39
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 374 additions and 219 deletions
devops/postgres/schema.sql
View file @ 254e5d36
......@@ -135,16 +135,27 @@ CREATE TABLE public.nodes_nodes (
ALTER TABLE public.nodes_nodes OWNER TO gargantua;
-- To attach contexts to a Corpus
CREATE TABLE public.nodes_contexts (
id SERIAL ,
node_id INTEGER NOT NULL REFERENCES public.nodes(id) ON DELETE CASCADE,
context_id INTEGER NOT NULL REFERENCES public.contexts(id) ON DELETE CASCADE,
score REAL ,
category INTEGER ,
PRIMARY KEY (node_id, context_id)
PRIMARY KEY (id)
);
ALTER TABLE public.nodes_contexts OWNER TO gargantua;
CREATE TABLE public.nodescontexts_nodescontexts (
nodescontexts1 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
nodescontexts2 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
PRIMARY KEY (nodescontexts1, nodescontexts2)
);
ALTER TABLE public.nodescontexts_nodescontexts OWNER TO gargantua;
---------------------------------------------------------------
CREATE TABLE public.context_node_ngrams (
context_id INTEGER NOT NULL REFERENCES public.contexts (id) ON DELETE CASCADE,
......@@ -157,7 +168,7 @@ CREATE TABLE public.context_node_ngrams (
ALTER TABLE public.context_node_ngrams OWNER TO gargantua;
CREATE TABLE public.context_node_ngrams2 (
context_id INTEGER NOT NULL REFERENCES public.contexts (id) ON DELETE CASCADE,
context_id INTEGER NOT NULL REFERENCES public.contexts (id) ON DELETE CASCADE,
nodengrams_id INTEGER NOT NULL REFERENCES public.node_ngrams (id) ON DELETE CASCADE,
weight double precision,
PRIMARY KEY (context_id, nodengrams_id)
......@@ -185,8 +196,6 @@ PRIMARY KEY (node_id, nodengrams_id)
ALTER TABLE public.node_node_ngrams2 OWNER TO gargantua;
--------------------------------------------------------------
--CREATE TABLE public.nodes_ngrams_repo (
......@@ -230,7 +239,7 @@ CREATE INDEX ON public.contexts USING btree (id, typename, date DESC);
CREATE INDEX ON public.contexts USING btree (typename, id);
CREATE UNIQUE INDEX ON public.contexts USING btree (hash_id);
CREATE INDEX ON public.nodescontexts_nodescontexts USING btree (nodescontexts1, nodescontexts2);
-- CREATE UNIQUE INDEX ON public.nodes USING btree (((hyperdata ->> 'uniqId'::text)));
-- CREATE UNIQUE INDEX ON public.nodes USING btree (((hyperdata ->> 'uniqIdBdd'::text)));
-- CREATE UNIQUE INDEX ON public.nodes USING btree (typename, parent_id, ((hyperdata ->> 'uniqId'::text)));
......@@ -249,6 +258,7 @@ CREATE UNIQUE INDEX ON public.node_ngrams USING btree (node_id,node_subtype, ngr
CREATE UNIQUE INDEX ON public.nodes_nodes USING btree (node1_id, node2_id);
CREATE INDEX ON public.nodes_nodes USING btree (node1_id, node2_id, category);
-- To make the links between Corpus Node and its contexts
CREATE UNIQUE INDEX ON public.nodes_contexts USING btree (node_id, context_id);
CREATE INDEX ON public.nodes_contexts USING btree (node_id, context_id, category);
......
devops/postgres/upgrade/0.0.5.7.5.sql 0 → 100644
View file @ 254e5d36
ALTER TABLE nodes_contexts DROP CONSTRAINT nodes_contexts_pkey;
ALTER TABLE nodes_contexts ADD COLUMN id SERIAL PRIMARY KEY ;
CREATE TABLE public.nodescontexts_nodescontexts (
nodescontexts1 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
nodescontexts2 INTEGER NOT NULL REFERENCES public.nodes_contexts(id) ON DELETE CASCADE,
PRIMARY KEY (nodescontexts1, nodescontexts2)
);
ALTER TABLE public.nodescontexts_nodescontexts OWNER TO gargantua;
CREATE INDEX ON public.nodescontexts_nodescontexts USING btree (nodescontexts1, nodescontexts2)
src/Gargantext/API/Client.hs
View file @ 254e5d36
......@@ -116,7 +116,7 @@ postNodeSearch :: Token -> NodeId -> SearchQuery -> Maybe Int -> Maybe Int -> Ma
postNodeShare :: Token -> NodeId -> ShareNodeParams -> ClientM Int
postNodePairCorpusAnnuaire :: Token -> NodeId -> AnnuaireId -> Maybe ListId -> ClientM Int
postNodePairCorpusAnnuaire :: Token -> NodeId -> AnnuaireId -> Maybe ListId -> ClientM [Int]
getNodePairs :: Token -> NodeId -> ClientM [AnnuaireId]
getNodePairings :: Token -> NodeId -> Maybe TabType -> Maybe Int -> Maybe Int -> Maybe Facet.OrderBy -> ClientM [FacetDoc]
......@@ -205,7 +205,7 @@ postCorpusSearch :: Token -> CorpusId -> SearchQuery -> Maybe Int -> Maybe Int -
postCorpusShare :: Token -> CorpusId -> ShareNodeParams -> ClientM Int
postCorpusPairCorpusAnnuaire :: Token -> CorpusId -> AnnuaireId -> Maybe ListId -> ClientM Int
postCorpusPairCorpusAnnuaire :: Token -> CorpusId -> AnnuaireId -> Maybe ListId -> ClientM [Int]
getCorpusPairs :: Token -> CorpusId -> ClientM [AnnuaireId]
getCorpusPairings :: Token -> CorpusId -> Maybe TabType -> Maybe Int -> Maybe Int -> Maybe Facet.OrderBy -> ClientM [FacetDoc]
......@@ -299,7 +299,7 @@ putAnnuaireScore :: Token -> AnnuaireId -> NodesToScore -> ClientM [Int]
postAnnuaireSearch :: Token -> AnnuaireId -> SearchQuery -> Maybe Int -> Maybe Int -> Maybe Facet.OrderBy -> ClientM SearchResult
postAnnuaireShare :: Token -> AnnuaireId -> ShareNodeParams -> ClientM Int
postAnnuairePairCorpusAnnuaire :: Token -> AnnuaireId -> AnnuaireId -> Maybe ListId -> ClientM Int
postAnnuairePairCorpusAnnuaire :: Token -> AnnuaireId -> AnnuaireId -> Maybe ListId -> ClientM [Int]
getAnnuairePairs :: Token -> AnnuaireId -> ClientM [AnnuaireId]
getAnnuairePairings :: Token -> AnnuaireId -> Maybe TabType -> Maybe Int -> Maybe Int -> Maybe Facet.OrderBy -> ClientM [FacetDoc]
......
src/Gargantext/API/Ngrams/Tools.hs
View file @ 254e5d36
......@@ -135,16 +135,16 @@ filterListWithRootHashMap lt m = snd <$> HM.filter isMapTerm m
Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
Just (l',_) -> l' == lt
filterListWithRoot :: ListType
filterListWithRoot :: [ListType]
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap NgramsTerm (Maybe RootTerm)
filterListWithRoot lt m = snd <$> HM.filter isMapTerm m
where
isMapTerm (l, maybeRoot) = case maybeRoot of
Nothing -> l == lt
Nothing -> elem l lt
Just r -> case HM.lookup r m of
Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
Just (l',_) -> l' == lt
Just (l',_) -> elem l' lt
groupNodesByNgrams :: ( At root_map
, Index root_map ~ NgramsTerm
......
src/Gargantext/API/Node.hs
View file @ 254e5d36
......@@ -312,7 +312,7 @@ pairs cId = do
type PairWith = Summary "Pair a Corpus with an Annuaire"
:> "annuaire" :> Capture "annuaire_id" AnnuaireId
:> QueryParam "list_id" ListId
:> Post '[JSON] Int
:> Post '[JSON] [Int]
pairWith :: CorpusId -> GargServer PairWith
pairWith cId aId lId = do
......
src/Gargantext/API/Node/Corpus/Export.hs
View file @ 254e5d36
......@@ -95,7 +95,7 @@ getContextNgrams cId lId listType nt repo = do
-- Just l -> pure l
lIds <- selectNodesWithUsername NodeList userMaster
let ngs = filterListWithRoot listType $ mapTermListRoot [lId] nt repo
let ngs = filterListWithRoot [listType] $ mapTermListRoot [lId] nt repo
-- TODO HashMap
r <- getNgramsByContextOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
pure r
......
src/Gargantext/Core/Viz/Chart.hs
View file @ 254e5d36
......@@ -61,7 +61,7 @@ chartData cId nt lt = do
ls <- map (_node_id) <$> getListsWithParentId cId
ts <- mapTermListRoot ls nt <$> getRepo' ls
let
dico = filterListWithRoot lt ts
dico = filterListWithRoot [lt] ts
terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ HashMap.toList dico
group dico' x = case HashMap.lookup x dico' of
Nothing -> x
......@@ -86,7 +86,7 @@ treeData cId nt lt = do
ts <- mapTermListRoot ls nt <$> getRepo' ls
let
dico = filterListWithRoot lt ts
dico = filterListWithRoot [lt] ts
terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ HashMap.toList dico
cs' <- getContextsByNgramsOnlyUser cId (ls' <> ls) nt terms
......
src/Gargantext/Core/Viz/Graph/API.hs
View file @ 254e5d36
......@@ -174,7 +174,7 @@ computeGraph cId method d nt repo = do
lId <- defaultList cId
lIds <- selectNodesWithUsername NodeList userMaster
let ngs = filterListWithRoot MapTerm
let ngs = filterListWithRoot [MapTerm]
$ mapTermListRoot [lId] nt repo
myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
......
src/Gargantext/Database/Action/Metrics.hs
View file @ 254e5d36
......@@ -234,8 +234,9 @@ getNgrams :: (HasMail env, HasNodeStory env err m)
getNgrams lId tabType = do
lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo' [lId]
-- TODO filterListWithRoot [MapTerm, StopTerm, CandidateTerm] lists
let maybeSyn = HM.unions $ map (\t -> filterListWithRoot t lists)
[MapTerm, StopTerm, CandidateTerm]
[[MapTerm], [StopTerm], [CandidateTerm]]
pure (lists, maybeSyn)
-- Some useful Tools
......
src/Gargantext/Database/Action/Metrics/NgramsByContext.hs
View file @ 254e5d36
......@@ -172,7 +172,7 @@ selectNgramsOccurrencesOnlyByContextUser_withSample cId int nt tms =
queryNgramsOccurrencesOnlyByContextUser_withSample :: DPS.Query
queryNgramsOccurrencesOnlyByContextUser_withSample = [sql|
WITH nodes_sample AS (SELECT id FROM contexts n TABLESAMPLE SYSTEM_ROWS (?)
WITH nodes_sample AS (SELECT n.id FROM contexts n TABLESAMPLE SYSTEM_ROWS (?)
JOIN nodes_contexts nn ON n.id = nn.context_id
WHERE n.typename = ?
AND nn.node_id = ?),
......
src/Gargantext/Database/Action/Search.hs
View file @ 254e5d36
......@@ -26,8 +26,8 @@ import Gargantext.Database.Query.Filter
import Gargantext.Database.Query.Join (leftJoin5)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Context
import Gargantext.Database.Query.Table.NodeNode
import Gargantext.Database.Query.Table.NodeContext
import Gargantext.Database.Query.Table.NodeContext_NodeContext
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.Context
import Gargantext.Prelude
......@@ -41,11 +41,11 @@ searchDocInDatabase :: HasDBid NodeType
=> ParentId
-> Text
-> Cmd err [(NodeId, HyperdataDocument)]
searchDocInDatabase _p t = runOpaQuery (queryDocInDatabase t)
searchDocInDatabase p t = runOpaQuery (queryDocInDatabase p t)
where
-- | Global search query where ParentId is Master Node Corpus Id
queryDocInDatabase :: Text -> O.Select (Column SqlInt4, Column SqlJsonb)
queryDocInDatabase q = proc () -> do
queryDocInDatabase :: ParentId -> Text -> O.Select (Column SqlInt4, Column SqlJsonb)
queryDocInDatabase _p q = proc () -> do
row <- queryNodeSearchTable -< ()
restrict -< (_ns_search row) @@ (sqlTSQuery (unpack q))
restrict -< (_ns_typename row) .== (sqlInt4 $ toDBid NodeDocument)
......@@ -118,11 +118,22 @@ searchInCorpusWithContacts
searchInCorpusWithContacts cId aId q o l _order =
runOpaQuery $ limit' l
$ offset' o
$ orderBy ( desc _fp_score)
$ orderBy (desc _fp_score)
$ selectGroup cId aId
$ intercalate " | "
$ map stemIt q
selectGroup :: HasDBid NodeType
=> CorpusId
-> AnnuaireId
-> Text
-> Select FacetPairedReadNull
selectGroup cId aId q = proc () -> do
(a, b, c, d) <- aggregate (p4 (groupBy, groupBy, groupBy, O.sum))
(selectContactViaDoc cId aId q) -< ()
returnA -< FacetPaired a b c d
selectContactViaDoc
:: HasDBid NodeType
=> CorpusId
......@@ -134,81 +145,68 @@ selectContactViaDoc
, Column (Nullable SqlJsonb)
, Column (Nullable SqlInt4)
)
selectContactViaDoc cId aId q = proc () -> do
(doc, (corpus_doc, (_contact_doc, (annuaire_contact, contact)))) <- queryContactViaDoc -< ()
restrict -< (doc^.ns_search) @@ (sqlTSQuery $ unpack q )
restrict -< (doc^.ns_typename) .== (sqlInt4 $ toDBid NodeDocument)
restrict -< (corpus_doc^.nn_node1_id) .== (toNullable $ pgNodeId cId)
restrict -< (annuaire_contact^.nn_node1_id) .== (toNullable $ pgNodeId aId)
restrict -< (contact^.node_typename) .== (toNullable $ sqlInt4 $ toDBid NodeContact)
returnA -< ( contact^.node_id
, contact^.node_date
, contact^.node_hyperdata
selectContactViaDoc cId aId query = proc () -> do
(doc, (corpus, (_nodeContext_nodeContext, (annuaire, contact)))) <- queryContactViaDoc -< ()
restrict -< (doc^.cs_search) @@ (sqlTSQuery $ unpack query )
restrict -< (doc^.cs_typename) .== (sqlInt4 $ toDBid NodeDocument )
restrict -< (corpus^.nc_node_id) .== (toNullable $ pgNodeId cId )
restrict -< (annuaire^.nc_node_id) .== (toNullable $ pgNodeId aId )
restrict -< (contact^.context_typename) .== (toNullable $ sqlInt4 $ toDBid NodeContact)
returnA -< ( contact^.context_id
, contact^.context_date
, contact^.context_hyperdata
, toNullable $ sqlInt4 1
)
selectGroup :: HasDBid NodeType
=> NodeId
-> NodeId
-> Text
-> Select FacetPairedReadNull
selectGroup cId aId q = proc () -> do
(a, b, c, d) <- aggregate (p4 (groupBy, groupBy, groupBy, O.sum))
(selectContactViaDoc cId aId q) -< ()
returnA -< FacetPaired a b c d
queryContactViaDoc :: O.Select ( NodeSearchRead
, ( NodeNodeReadNull
, ( NodeNodeReadNull
, ( NodeNodeReadNull
, NodeReadNull
queryContactViaDoc :: O.Select ( ContextSearchRead
, ( NodeContextReadNull
, ( NodeContext_NodeContextReadNull
, ( NodeContextReadNull
, ContextReadNull
)
)
)
)
queryContactViaDoc =
leftJoin5
queryNodeTable
queryNodeNodeTable
queryNodeNodeTable
queryNodeNodeTable
queryNodeSearchTable
queryContextTable
queryNodeContextTable
queryNodeContext_NodeContextTable
queryNodeContextTable
queryContextSearchTable
cond12
cond23
cond34
cond45
where
cond12 :: (NodeNodeRead, NodeRead) -> Column SqlBool
cond12 (annuaire_contact, contact) = contact^.node_id .== annuaire_contact^.nn_node2_id
cond12 :: (NodeContextRead, ContextRead) -> Column SqlBool
cond12 (annuaire, contact) = contact^.context_id .== annuaire^.nc_context_id
cond23 :: ( NodeNodeRead
, ( NodeNodeRead
, NodeReadNull
cond23 :: ( NodeContext_NodeContextRead
, ( NodeContextRead
, ContextReadNull
)
) -> Column SqlBool
cond23 (contact_doc, (annuaire_contact, _)) = contact_doc^.nn_node1_id .== annuaire_contact^.nn_node2_id
cond23 (nodeContext_nodeContext, (annuaire, _)) = nodeContext_nodeContext^.ncnc_nodecontext2 .== annuaire^.nc_id
cond34 :: ( NodeNodeRead
, ( NodeNodeRead
, ( NodeNodeReadNull
, NodeReadNull
cond34 :: ( NodeContextRead
, ( NodeContext_NodeContextRead
, ( NodeContextReadNull
, ContextReadNull
)
)
) -> Column SqlBool
cond34 (corpus_doc, (contact_doc, (_,_))) = corpus_doc^.nn_node2_id .== contact_doc^.nn_node2_id
cond34 (corpus, (nodeContext_nodeContext, (_,_))) = nodeContext_nodeContext^.ncnc_nodecontext1 .== corpus^.nc_id
cond45 :: ( NodeSearchRead
, ( NodeNodeRead
, ( NodeNodeReadNull
, ( NodeNodeReadNull
, NodeReadNull
cond45 :: ( ContextSearchRead
, ( NodeContextRead
, ( NodeContext_NodeContextReadNull
, ( NodeContextReadNull
, ContextReadNull
)
)
)
) -> Column SqlBool
cond45 (doc, (corpus_doc, (_,(_,_)))) = doc^.ns_id .== corpus_doc^.nn_node2_id
cond45 (doc, (corpus, (_,(_,_)))) = doc^.cs_id .== corpus^.nc_context_id
------------------------------------------------------------------------
src/Gargantext/Database/Admin/Types/Node.hs
View file @ 254e5d36
......@@ -187,13 +187,13 @@ instance (Arbitrary hyperdata
) where
--arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
arbitrary = ContextSearch <$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
......@@ -212,10 +212,13 @@ pgContextId = pgNodeId
newtype NodeId = NodeId Int
deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
-- TODO make another type?
-- TODO make another type
type ContextId = NodeId
newtype NodeContextId = NodeContextId Int
deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
instance GQLType NodeId
instance Show NodeId where
show (NodeId n) = "nodeId-" <> show n
......
src/Gargantext/Database/Query/Table/Context.hs
View file @ 254e5d36
{-|
import Gargantext.Database.Prelude (Cmd, runPGSQuery)
Module : Gargantext.Database.Query.Table.Node
Description : Main Tools of Node to the database
Copyright : (c) CNRS, 2017-Present
......@@ -9,7 +8,6 @@ Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
......@@ -31,8 +29,8 @@ import Gargantext.Database.Query.Filter (limit', offset')
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Schema.Context
import Gargantext.Prelude hiding (sum, head)
import Opaleye hiding (FromField)
import Prelude hiding (null, id, map, sum)
import Opaleye hiding (FromField)
import Prelude hiding (null, id, map, sum)
getContextWith :: (HasNodeError err, JSONB a)
......
src/Gargantext/Database/Query/Table/Node/Children.hs
View file @ 254e5d36
......@@ -84,9 +84,9 @@ getChildrenNode pId _ maybeNodeType maybeOffset maybeLimit = do
selectChildrenNode :: HasDBid NodeType
=> ParentId
-> Maybe NodeType
-> Select NodeRead
=> ParentId
-> Maybe NodeType
-> Select NodeRead
selectChildrenNode parentId maybeNodeType = proc () -> do
row@(Node _ _ typeName _ parent_id _ _ _) <- queryNodeTable -< ()
let nodeType = maybe 0 toDBid maybeNodeType
......@@ -122,7 +122,7 @@ selectChildren' :: HasDBid NodeType
-> Select ContextRead
selectChildren' parentId maybeNodeType = proc () -> do
row@(Context cid _ typeName _ _ _ _ _) <- queryContextTable -< ()
(NodeContext nid cid' _ _) <- queryNodeContextTable -< ()
(NodeContext _ nid cid' _ _) <- queryNodeContextTable -< ()
let nodeType = maybe 0 toDBid maybeNodeType
restrict -< typeName .== sqlInt4 nodeType
......
src/Gargantext/Database/Query/Table/NodeContext.hs
View file @ 254e5d36
......@@ -77,8 +77,9 @@ insertNodeContext ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
$ Insert nodeContextTable ns' rCount (Just DoNothing))
where
ns' :: [NodeContextWrite]
ns' = map (\(NodeContext n c x y)
-> NodeContext (pgNodeId n)
ns' = map (\(NodeContext i n c x y)
-> NodeContext (sqlInt4 <$> i)
(pgNodeId n)
(pgNodeId c)
(sqlDouble <$> x)
(sqlInt4 <$> y)
......@@ -93,7 +94,7 @@ deleteNodeContext :: Node_Id -> Context_Id -> Cmd err Int
deleteNodeContext n c = mkCmd $ \conn ->
fromIntegral <$> runDelete_ conn
(Delete nodeContextTable
(\(NodeContext n_id c_id _ _) -> n_id .== pgNodeId n
(\(NodeContext _ n_id c_id _ _) -> n_id .== pgNodeId n
.&& c_id .== pgNodeId c
)
rCount
......
src/Gargantext/Database/Query/Table/NodeContext_NodeContext.hs 0 → 100644
View file @ 254e5d36
{-|
Module : Gargantext.Database.Select.Table.NodeContext_NodeContext
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Query.Table.NodeContext_NodeContext
( module Gargantext.Database.Schema.NodeContext_NodeContext
-- , query_NodeContext_NodeContext_Table
, insertNodeContext_NodeContext
)
where
import Data.Text (Text)
import Gargantext.Core.Types
import Gargantext.Database.Prelude
import Gargantext.Database.Schema.NodeContext_NodeContext
import Gargantext.Database.Schema.Prelude hiding (sum)
import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as PGS
{-
queryNodeContext_NodeContextTable :: Select NodeContext_NodeContextRead
queryNodeContext_NodeContextTable = selectTable nodeContext_NodeContextTable
-}
insertNodeContext_NodeContext :: [(CorpusId, DocId, AnnuaireId, ContactId)] -> Cmd err [Int]
insertNodeContext_NodeContext contexts = do
let
fields = map (\t -> QualifiedIdentifier Nothing t) $ snd fields_name
fields_name :: ( [Text], [Text])
fields_name = ( ["corpus_id", "doc_id", "annuaire_id", "contact_id"]
, ["int4" , "int4" , "int4" , "int4" ]
)
result <- map (\(PGS.Only a) -> a) <$> runPGSQuery queryInsert (PGS.Only $ Values fields contexts)
pure [sum result]
queryInsert :: PGS.Query
queryInsert = [sql|
WITH input(corpus_id, doc_id, annuaire_id, contact_id) AS (?)
INSERT into nodescontexts_nodescontexts (nodescontexts1, nodescontexts2)
SELECT context1.id, context2.id FROM input
INNER JOIN nodes_contexts context1 ON context1.node_id = input.corpus_id
INNER JOIN nodes_contexts context2 ON context2.node_id = input.annuaire_id
WHERE context1.context_id = input.doc_id
AND context2.context_id = input.contact_id
ON CONFLICT (nodescontexts1, nodescontexts2) DO Nothing
RETURNING 1
|]
src/Gargantext/Database/Schema/NodeContext.hs
View file @ 254e5d36
......@@ -26,29 +26,33 @@ import Gargantext.Database.Schema.NodeNode () -- Just importing some instances
import Gargantext.Prelude
data NodeContextPoly node_id context_id score cat
= NodeContext { _nc_node_id :: !node_id
data NodeContextPoly id node_id context_id score cat
= NodeContext { _nc_id :: !id
, _nc_node_id :: !node_id
, _nc_context_id :: !context_id
, _nc_score :: !score
, _nc_category :: !cat
} deriving (Show)
type NodeContextWrite = NodeContextPoly (Column (SqlInt4))
(Column (SqlInt4))
(Maybe (Column (SqlFloat8)))
(Maybe (Column (SqlInt4)))
type NodeContextWrite = NodeContextPoly (Maybe (Column (SqlInt4)))
(Column (SqlInt4))
(Column (SqlInt4))
(Maybe (Column (SqlFloat8)))
(Maybe (Column (SqlInt4)))
type NodeContextRead = NodeContextPoly (Column (SqlInt4))
(Column (SqlInt4))
(Column (SqlFloat8))
(Column (SqlInt4))
(Column (SqlInt4))
(Column (SqlInt4))
(Column (SqlFloat8))
(Column (SqlInt4))
type NodeContextReadNull = NodeContextPoly (Column (Nullable SqlInt4))
(Column (Nullable SqlInt4))
(Column (Nullable SqlFloat8))
(Column (Nullable SqlInt4))
(Column (Nullable SqlInt4))
(Column (Nullable SqlInt4))
(Column (Nullable SqlFloat8))
(Column (Nullable SqlInt4))
type NodeContext = NodeContextPoly NodeId NodeId (Maybe Double) (Maybe Int)
type NodeContext = NodeContextPoly (Maybe Int) NodeId NodeId (Maybe Double) (Maybe Int)
$(makeAdaptorAndInstance "pNodeContext" ''NodeContextPoly)
makeLenses ''NodeContextPoly
......@@ -57,7 +61,8 @@ nodeContextTable :: Table NodeContextWrite NodeContextRead
nodeContextTable =
Table "nodes_contexts"
( pNodeContext
NodeContext { _nc_node_id = requiredTableField "node_id"
NodeContext { _nc_id = optionalTableField "id"
, _nc_node_id = requiredTableField "node_id"
, _nc_context_id = requiredTableField "context_id"
, _nc_score = optionalTableField "score"
, _nc_category = optionalTableField "category"
......
src/Gargantext/Database/Schema/NodeContext_NodeContext.hs 0 → 100644
View file @ 254e5d36
{-|
Module : Gargantext.Database.Schema.ContextContext
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.NodeContext_NodeContext where
import Gargantext.Core.Types
import Gargantext.Database.Schema.Prelude
import Gargantext.Prelude
data NodeContext_NodeContextPoly nodecontext1 nodecontext2
= NodeContext_NodeContext { _ncnc_nodecontext1 :: !nodecontext1
, _ncnc_nodecontext2 :: !nodecontext2
} deriving (Show)
type NodeContext_NodeContextWrite = NodeContext_NodeContextPoly (Column (SqlInt4))
(Column (SqlInt4))
type NodeContext_NodeContextRead = NodeContext_NodeContextPoly (Column (SqlInt4))
(Column (SqlInt4))
type NodeContext_NodeContextReadNull = NodeContext_NodeContextPoly (Column (Nullable SqlInt4))
(Column (Nullable SqlInt4))
type NodeContext_NodeContext = NodeContext_NodeContextPoly NodeContextId NodeContextId
$(makeAdaptorAndInstance "pNodeContext_NodeContext" ''NodeContext_NodeContextPoly)
makeLenses ''NodeContext_NodeContextPoly
nodeContext_NodeContextTable :: Table NodeContext_NodeContextWrite NodeContext_NodeContextRead
nodeContext_NodeContextTable =
Table "nodescontexts_nodescontexts"
( pNodeContext_NodeContext
NodeContext_NodeContext { _ncnc_nodecontext1 = requiredTableField "nodescontexts1"
, _ncnc_nodecontext2 = requiredTableField "nodescontexts2"
}
)
queryNodeContext_NodeContextTable :: Query NodeContext_NodeContextRead
queryNodeContext_NodeContextTable = selectTable nodeContext_NodeContextTable
src/Gargantext/Database/Schema/NodeNode.hs
View file @ 254e5d36
......@@ -11,8 +11,6 @@ Here is a longer description of this module, containing some
commentary with @some markup@.
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
......@@ -63,18 +61,3 @@ nodeNodeTable =
}
)
instance DefaultFromField (Nullable SqlInt4) Int where
defaultFromField = fromPGSFromField
instance DefaultFromField (Nullable SqlFloat8) Int where
defaultFromField = fromPGSFromField
instance DefaultFromField (Nullable SqlFloat8) Double where
defaultFromField = fromPGSFromField
instance DefaultFromField SqlFloat8 (Maybe Double) where
defaultFromField = fromPGSFromField
instance DefaultFromField SqlInt4 (Maybe Int) where
defaultFromField = fromPGSFromField
src/Gargantext/Database/Types.hs
View file @ 254e5d36
......@@ -9,6 +9,7 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Types
......@@ -40,3 +41,19 @@ instance HasText a => HasText (Indexed i a)
hasText (Indexed _ a) = hasText a
instance (Hashable a, Hashable b) => Hashable (Indexed a b)
instance DefaultFromField (Nullable SqlInt4) Int where
defaultFromField = fromPGSFromField
instance DefaultFromField (Nullable SqlFloat8) Int where
defaultFromField = fromPGSFromField
instance DefaultFromField (Nullable SqlFloat8) Double where
defaultFromField = fromPGSFromField
instance DefaultFromField SqlFloat8 (Maybe Double) where
defaultFromField = fromPGSFromField
instance DefaultFromField SqlInt4 (Maybe Int) 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