Skip to content

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

Merge branch 'dev' into dev-getting-started-readme

parents 7826213e 6d58acdd
Show whitespace changes
Inline Side-by-side
Showing with 413 additions and 143 deletions
devops/postgres/schema.sql
View file @ 51513857
......@@ -166,7 +166,7 @@ CREATE INDEX ON public.nodes_nodes USING btree (node1_id, node2_id, cate
CREATE UNIQUE INDEX ON public.node_node_ngrams USING btree (node1_id, node2_id, ngrams_id, ngrams_type);
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);
CREATE INDEX ON public.node_node_ngrams USING btree (ngrams_type);
CREATE INDEX ON public.node_nodengrams_nodengrams USING btree (node_id, node_ngrams1_id, node_ngrams2_id);
CREATE INDEX ON public.node_nodengrams_nodengrams USING btree (node_ngrams1_id);
CREATE INDEX ON public.node_nodengrams_nodengrams USING btree (node_ngrams2_id);
......
src/Gargantext/API.hs
View file @ 51513857
......@@ -15,12 +15,14 @@ This API is indeed typed in order to be able to derive both the server
and the client sides.
The Garg-API-Monad enables:
- Features
- Security (WIP)
- Features (WIP)
- Database connection (long term)
- In Memory stack management (short term)
- Logs
- Logs (WIP)
Thanks to @yannEsposito (at the start) and @np (after).
Thanks to Yann Esposito for our discussions at the start and to Nicolas
Pouillard (who mainly made it).
-}
......@@ -92,6 +94,7 @@ import Gargantext.API.Ngrams (HasRepo(..), HasRepoSaver(..), saveRepo, TableNgra
import Gargantext.API.Node
import Gargantext.API.Search (SearchPairsAPI, searchPairs)
import Gargantext.API.Types
import qualified Gargantext.API.Export as Export
import qualified Gargantext.API.Corpus.New as New
import Gargantext.Database.Types.Node
import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
......@@ -260,6 +263,9 @@ type GargPrivateAPI' =
:> Capture "node2_id" NodeId
:> NodeNodeAPI HyperdataAny
:<|> "corpus" :> Capture "node_id" CorpusId
:> Export.API
-- Annuaire endpoint
:<|> "annuaire":> Summary "Annuaire endpoint"
:> Capture "annuaire_id" AnnuaireId
......@@ -310,9 +316,11 @@ type GargPrivateAPI' =
-- :<|> "ngrams" :> Capture "node_id" Int :> NodeAPI
-- :<|> "auth" :> Capture "node_id" Int :> NodeAPI
---------------------------------------------------------------------
type SwaggerFrontAPI = SwaggerAPI :<|> FrontEndAPI
type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html
type API = SwaggerAPI
:<|> FrontEndAPI
:<|> GargAPI
:<|> Get '[HTML] Html
-- This is the concrete monad. It needs to be used as little as possible,
-- instead, prefer GargServer, GargServerT, GargServerC.
......@@ -331,7 +339,8 @@ type EnvC env =
server :: forall env. EnvC env => env -> IO (Server API)
server env = do
-- orchestrator <- scrapyOrchestrator env
pure $ swaggerFront
pure $ schemaUiServer swaggerDoc
:<|> frontEndServer
:<|> hoistServerWithContext (Proxy :: Proxy GargAPI) (Proxy :: Proxy AuthContext) transform serverGargAPI
:<|> serverStatic
where
......@@ -361,6 +370,7 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
:<|> nodeAPI (Proxy :: Proxy HyperdataAny) uid
:<|> nodeAPI (Proxy :: Proxy HyperdataCorpus) uid
:<|> nodeNodeAPI (Proxy :: Proxy HyperdataAny) uid
:<|> Export.getCorpus -- uid
:<|> nodeAPI (Proxy :: Proxy HyperdataAnnuaire) uid
:<|> nodeNodeAPI (Proxy :: Proxy HyperdataContact) uid
......@@ -414,13 +424,8 @@ serverStatic = $(do
)
---------------------------------------------------------------------
swaggerFront :: Server SwaggerFrontAPI
swaggerFront = schemaUiServer swaggerDoc
:<|> frontEndServer
--gargMock :: Server GargAPI
--gargMock = mock apiGarg Proxy
---------------------------------------------------------------------
makeApp :: EnvC env => env -> IO Application
makeApp env = serveWithContext api cfg <$> server env
......@@ -433,7 +438,6 @@ makeApp env = serveWithContext api cfg <$> server env
--appMock :: Application
--appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
---------------------------------------------------------------------
api :: Proxy API
api = Proxy
......@@ -441,12 +445,10 @@ api = Proxy
apiGarg :: Proxy GargAPI
apiGarg = Proxy
---------------------------------------------------------------------
schemaUiServer :: (Server api ~ Handler Swagger)
=> Swagger -> Server (SwaggerSchemaUI' dir api)
schemaUiServer = swaggerSchemaUIServer
-- Type Family for the Documentation
type family TypeName (x :: *) :: Symbol where
TypeName Int = "Int"
......
src/Gargantext/API/Export.hs 0 → 100644
View file @ 51513857
{-|
Module : Gargantext.API.Export
Description : Get Metrics from Storage (Database like)
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Main exports of Gargantext:
- corpus
- document and ngrams
- lists
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.API.Export
where
import Data.Aeson.TH (deriveJSON)
import Data.Map (Map)
import Data.Set (Set)
import Data.Maybe (fromMaybe)
import Data.Swagger
import Data.Text (Text)
import GHC.Generics (Generic)
import Gargantext.API.Ngrams
import Gargantext.API.Ngrams.Tools (filterListWithRoot, mapTermListRoot, getRepo)
import Gargantext.API.Types (GargNoServer)
import Gargantext.Core.Types --
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Config (userMaster)
import Gargantext.Database.Metrics.NgramsByNode (getNgramsByNodeOnlyUser)
import Gargantext.Database.Node.Select (selectNodesWithUsername)
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
import Gargantext.Database.Schema.NodeNode (selectDocNodes)
import Gargantext.Database.Types.Node (Node, HyperdataDocument(..), NodeId, ListId, CorpusId)
import Gargantext.Database.Utils (Cmd)
import Gargantext.Prelude
import Gargantext.Prelude.Utils (sha)
import Servant
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
-- Corpus Export
data Corpus =
Corpus { _c_corpus :: [Document]
, _c_hash :: Hash
} deriving (Generic)
-- | Document Export
data Document =
Document { _d_document :: Node HyperdataDocument
, _d_ngrams :: Ngrams
, _d_hash :: Hash
} deriving (Generic)
data Ngrams =
Ngrams { _ng_ngrams :: [Text]
, _ng_hash :: Hash
} deriving (Generic)
type Hash = Text
-------
instance ToSchema Corpus where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_c_")
instance ToSchema Document where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_d_")
instance ToSchema Ngrams where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ng_")
-------
instance ToParamSchema Corpus where
toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
instance ToParamSchema Document where
toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
instance ToParamSchema Ngrams where
toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
--------------------------------------------------
type API = Summary "Corpus Export"
:> "export"
:> QueryParam "listId" ListId
:> QueryParam "ngramsType" NgramsType
:> Get '[JSON] Corpus
--------------------------------------------------
getCorpus :: CorpusId
-> Maybe ListId
-> Maybe NgramsType
-> GargNoServer Corpus
getCorpus cId lId nt' = do
let
nt = case nt' of
Nothing -> NgramsTerms
Just t -> t
ns <- Map.fromList
<$> map (\n -> (_node_id n, n))
<$> selectDocNodes cId
repo <- getRepo
ngs <- getNodeNgrams cId lId nt repo
let -- uniqId is hash computed already for each document imported in database
r = Map.intersectionWith (\a b -> Document a (Ngrams (Set.toList b) (ng_hash b)) (d_hash a b)
) ns ngs
where
ng_hash b = sha $ List.foldl (\x y -> x<>y) "" $ List.sort $ Set.toList b
d_hash a b = sha $ (fromMaybe "" (_hyperdataDocument_uniqId $ _node_hyperdata a))
<> (ng_hash b)
pure $ Corpus (Map.elems r) (sha $ List.foldl (\a b -> a<>b) ""
$ List.map _d_hash $ Map.elems r
)
getNodeNgrams :: HasNodeError err
=> CorpusId
-> Maybe ListId
-> NgramsType
-> NgramsRepo
-> Cmd err (Map NodeId (Set Text))
getNodeNgrams cId lId' nt repo = do
lId <- case lId' of
Nothing -> defaultList cId
Just l -> pure l
lIds <- selectNodesWithUsername NodeList userMaster
let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
r <- getNgramsByNodeOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
pure r
$(deriveJSON (unPrefix "_c_") ''Corpus)
$(deriveJSON (unPrefix "_d_") ''Document)
$(deriveJSON (unPrefix "_ng_") ''Ngrams)
-- TODO
-- Exports List
-- Version number of the list
src/Gargantext/API/Ngrams.hs
View file @ 51513857
......@@ -78,7 +78,7 @@ module Gargantext.API.Ngrams
, HasRepo(..)
, RepoCmdM
, QueryParamR
, TODO(..)
, TODO
-- Internals
, getNgramsTableMap
......@@ -143,7 +143,7 @@ import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import qualified Gargantext.Database.Schema.Ngrams as Ngrams
-- import Gargantext.Database.Schema.NodeNgram hiding (Action)
import Gargantext.Prelude
-- import Gargantext.Core.Types (ListTypeId, listTypeId)
import Gargantext.Core.Types (TODO)
import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, HasInvalidError, assertValid)
import Servant hiding (Patch)
import System.Clock (getTime, TimeSpec, Clock(..))
......@@ -152,12 +152,6 @@ import System.IO (stderr)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
data TODO = TODO
deriving (Generic)
instance ToSchema TODO where
instance ToParamSchema TODO where
------------------------------------------------------------------------
--data FacetFormat = Table | Chart
data TabType = Docs | Trash | MoreFav | MoreTrash
......@@ -1044,14 +1038,14 @@ getTableNgrams _nType nId tabType listId limit_ offset
-- trace (show lists) $
-- getNgramsTableMap ({-lists <>-} listIds) ngramsType
let nSco = needsScores orderBy
let scoresNeeded = needsScores orderBy
tableMap1 <- getNgramsTableMap listId ngramsType
t1 <- getTime'
tableMap2 <- tableMap1 & v_data %%~ setScores nSco
tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
. Map.mapWithKey ngramsElementFromRepo
t2 <- getTime'
tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
. setScores (not nSco)
. setScores (not scoresNeeded)
. selectAndPaginate
t3 <- getTime'
liftIO $ hprint stderr
......@@ -1059,7 +1053,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
% " map1=" % timeSpecs
% " map2=" % timeSpecs
% " map3=" % timeSpecs
% " sql=" % (if nSco then "map2" else "map3")
% " sql=" % (if scoresNeeded then "map2" else "map3")
% "\n"
) t0 t3 t0 t1 t1 t2 t2 t3
pure tableMap3
......
src/Gargantext/API/Node.hs
View file @ 51513857
......@@ -12,7 +12,6 @@ Portability : POSIX
-- TODO-ACCESS: CanGetNode
-- TODO-EVENTS: No events as this is a read only query.
Node API
-------------------------------------------------------------------
-- TODO-ACCESS: access by admin only.
-- At first let's just have an isAdmin check.
......@@ -51,16 +50,17 @@ import Gargantext.API.Auth (withAccess, PathId(..))
import Gargantext.API.Metrics
import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR)
import Gargantext.API.Ngrams.NTree (MyTree)
import Gargantext.API.Search (SearchDocsAPI, searchDocs)
import Gargantext.API.Search (SearchDocsAPI, searchDocs, SearchPairsAPI, searchPairs)
import Gargantext.API.Table
import Gargantext.API.Types
import Gargantext.Core.Types (NodeTableResult)
import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Flow.Pairing (pairing)
import Gargantext.Database.Facet (FacetDoc, OrderBy(..))
import Gargantext.Database.Node.Children (getChildren)
import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNodeWith, getNode, deleteNode, deleteNodes, mkNodeWithParent, JSONB, HasNodeError(..))
import Gargantext.Database.Schema.NodeNode (nodeNodesCategory)
import Gargantext.Database.Schema.NodeNode -- (nodeNodesCategory, insertNodeNode, NodeNode(..))
import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Tree (treeDB)
import Gargantext.Database.Types.Node
......@@ -78,7 +78,6 @@ import qualified Gargantext.Text.List.Learn as Learn
import qualified Data.Vector as Vec
--}
type NodesAPI = Delete '[JSON] Int
-- | Delete Nodes
......@@ -128,11 +127,16 @@ type NodeAPI a = Get '[JSON] (Node a)
-- TODO gather it
:<|> "table" :> TableApi
:<|> "ngrams" :> TableNgramsApi
-- :<|> "pairing" :> PairingApi
:<|> "category" :> CatApi
:<|> "search" :> SearchDocsAPI
-- Pairing utilities
:<|> "pairwith" :> PairWith
:<|> "pairs" :> Pairs
:<|> "pairing" :> PairingApi
:<|> "searchPair" :> SearchPairsAPI
-- VIZ
:<|> "metrics" :> ScatterAPI
:<|> "chart" :> ChartApi
......@@ -188,12 +192,15 @@ nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode i
-- TODO gather it
:<|> tableApi id
:<|> apiNgramsTableCorpus id
-- :<|> getPairing id
-- :<|> getTableNgramsDoc id
:<|> catApi id
:<|> searchDocs id
-- Pairing Tools
:<|> pairWith id
:<|> pairs id
:<|> getPair id
:<|> searchPairs id
:<|> getScatter id
:<|> getChart id
......@@ -254,6 +261,7 @@ catApi = putCat
------------------------------------------------------------------------
-- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
-- Pairing utilities to move elsewhere
type PairingApi = Summary " Pairing API"
:> QueryParam "view" TabType
-- TODO change TabType -> DocType (CorpusId for pairing)
......@@ -262,6 +270,25 @@ type PairingApi = Summary " Pairing API"
:> QueryParam "order" OrderBy
:> Get '[JSON] [FacetDoc]
----------
type Pairs = Summary "List of Pairs"
:> Get '[JSON] [AnnuaireId]
pairs :: CorpusId -> GargServer Pairs
pairs cId = do
ns <- getNodeNode cId
pure $ map _nn_node2_id ns
type PairWith = Summary "Pair a Corpus with an Annuaire"
:> "annuaire" :> Capture "annuaire_id" AnnuaireId
:> "list" :> Capture "list_id" ListId
:> Post '[JSON] Int
pairWith :: CorpusId -> GargServer PairWith
pairWith cId aId lId = do
r <- pairing cId aId lId
_ <- insertNodeNode [ NodeNode cId aId Nothing Nothing]
pure r
------------------------------------------------------------------------
type ChartApi = Summary " Chart API"
:> QueryParam "from" UTCTime
......@@ -343,3 +370,4 @@ putNode :: forall err a. (HasNodeError err, JSONB a, ToJSON a)
-> Cmd err Int
putNode n h = fromIntegral <$> updateHyperdata n h
-------------------------------------------------------------
src/Gargantext/API/Orchestrator/Types.hs
View file @ 51513857
......@@ -22,7 +22,7 @@ import Servant.Job.Types
import Servant.Job.Utils (jsonOptions)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import Gargantext.API.Ngrams (TODO(..))
import Gargantext.Core.Types (TODO(..))
instance Arbitrary a => Arbitrary (JobStatus 'Safe a) where
arbitrary = panic "TODO"
......
src/Gargantext/API/Search.hs
View file @ 51513857
......@@ -79,8 +79,7 @@ instance ToSchema SearchPairedResults where
-----------------------------------------------------------------------
-- TODO-ACCESS: CanSearch? or is it part of CanGetNode
-- TODO-EVENTS: No event, this is a read-only query.
type SearchAPI results
= Summary "Search endpoint"
type SearchAPI results = Summary "Search endpoint"
:> ReqBody '[JSON] SearchQuery
:> QueryParam "offset" Int
:> QueryParam "limit" Int
......@@ -88,18 +87,20 @@ type SearchAPI results
:> Post '[JSON] results
type SearchDocsAPI = SearchAPI SearchDocResults
type SearchPairsAPI =
Summary "" :> "list" :> Capture "list" ListId
:> SearchAPI SearchPairedResults
-----------------------------------------------------------------------
searchPairs :: NodeId -> GargServer SearchPairsAPI
searchPairs pId lId (SearchQuery q) o l order =
SearchPairedResults <$> searchInCorpusWithContacts pId lId q o l order
searchDocs :: NodeId -> GargServer SearchDocsAPI
searchDocs nId (SearchQuery q) o l order =
SearchDocResults <$> searchInCorpus nId False q o l order
--SearchResults <$> searchInCorpusWithContacts nId q o l order
-----------------------------------------------------------------------
type SearchPairsAPI = Summary ""
:> "list"
:> Capture "list" ListId
:> SearchAPI SearchPairedResults
searchPairs :: NodeId -> GargServer SearchPairsAPI
searchPairs pId lId (SearchQuery q) o l order =
SearchPairedResults <$> searchInCorpusWithContacts pId lId q o l order
-----------------------------------------------------------------------
src/Gargantext/API/Table.hs
View file @ 51513857
......@@ -46,7 +46,7 @@ import GHC.Generics (Generic)
import Gargantext.API.Ngrams (TabType(..))
import Gargantext.Core.Types (Offset, Limit, TableResult(..))
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..))
import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..), runViewAuthorsDoc)
import Gargantext.Database.Learn (FavOrTrash(..), moreLike)
import Gargantext.Database.TextSearch
import Gargantext.Database.Types.Node
......@@ -121,14 +121,13 @@ getTable' cId ft o l order =
(Just MoreTrash) -> moreLike cId o l order IsTrash
x -> panic $ "not implemented in getTable: " <> (cs $ show x)
{-
getPairing :: ContactId -> Maybe TabType
getPair :: ContactId -> Maybe TabType
-> Maybe Offset -> Maybe Limit
-> Maybe OrderBy -> Cmd err [FacetDoc]
getPairing cId ft o l order =
getPair cId ft o l order =
case ft of
(Just Docs) -> runViewAuthorsDoc cId False o l order
(Just Trash) -> runViewAuthorsDoc cId True o l order
_ -> panic $ "not implemented: get Pairing" <> (cs $ show ft)
-}
src/Gargantext/API/Types.hs
View file @ 51513857
......@@ -94,6 +94,19 @@ type GargServerT env err m api = GargServerC env err m => ServerT api m
type GargServer api =
forall env err m. GargServerT env err m api
-------------------------------------------------------------------
-- | This Type is needed to prepare the function before the GargServer
type GargNoServer' env err m =
( CmdM env err m
, HasRepo env
, HasSettings env
, HasNodeError err
)
type GargNoServer t =
forall env err m. GargNoServer' env err m => m t
-------------------------------------------------------------------
data GargError
= GargNodeError NodeError
| GargTreeError TreeError
......
src/Gargantext/Core/Types.hs
View file @ 51513857
......@@ -25,32 +25,29 @@ module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
, Name
, TableResult(..)
, NodeTableResult
, TODO(..)
) where
--import qualified Data.Set as S
import Control.Lens (Prism', (#))
import Control.Monad.Error.Class (MonadError, throwError)
import Data.Aeson
import Data.Aeson.TH (deriveJSON)
import Data.Monoid
import Data.Semigroup
import Data.Set (Set, empty)
import Data.Swagger (ToParamSchema)
import Data.Swagger (ToSchema(..), genericDeclareNamedSchema)
--import qualified Data.Set as S
import Data.Text (Text, unpack)
import Data.Validity
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import GHC.Generics
import Gargantext.Core.Types.Main
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Types.Node
import Gargantext.Prelude
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import GHC.Generics
------------------------------------------------------------------------
type Name = Text
type Term = Text
type Stems = Set Text
......@@ -158,3 +155,13 @@ instance Arbitrary a => Arbitrary (TableResult a) where
arbitrary = TableResult <$> arbitrary <*> arbitrary
type NodeTableResult a = TableResult (Node a)
-- TO BE removed
data TODO = TODO
deriving (Generic)
instance ToSchema TODO where
instance ToParamSchema TODO where
src/Gargantext/Core/Types/Main.hs
View file @ 51513857
......@@ -52,8 +52,6 @@ instance ToSchema NodeTree where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nt_")
------------------------------------------------------------------------
--data Classification = Favorites | MyClassifcation
type HashId = Text
......
src/Gargantext/Database/Facet.hs
View file @ 51513857
......@@ -26,8 +26,8 @@ Portability : POSIX
{-# LANGUAGE TypeFamilies #-}
------------------------------------------------------------------------
module Gargantext.Database.Facet
( -- runViewAuthorsDoc
runViewDocuments
( runViewAuthorsDoc
, runViewDocuments
, filterWith
, Pair(..)
......@@ -57,9 +57,13 @@ import Gargantext.Core.Types
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.NodeNode
import Gargantext.Database.Schema.NodeNodeNgrams
-- import Gargantext.Database.Schema.NodeNodeNgrams2
import Gargantext.Database.Utils
import Gargantext.Database.Queries.Filter
import Gargantext.Database.Queries.Join (leftJoin5)
import Opaleye
import Prelude hiding (null, id, map, sum, not, read)
import Servant.API
......@@ -208,7 +212,7 @@ instance Arbitrary OrderBy
-- TODO-SECURITY check
{-
--{-
runViewAuthorsDoc :: ContactId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
where
......@@ -227,26 +231,31 @@ viewAuthorsDoc cId _ nt = proc () -> do
restrict -< _node_id contact .== (toNullable $ pgNodeId cId)
restrict -< _node_typename doc .== (pgInt4 $ nodeTypeId nt)
returnA -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (toNullable $ pgInt4 1) (toNullable $ pgDouble 1)
returnA -< FacetDoc (_node_id doc)
(_node_date doc)
(_node_name doc)
(_node_hyperdata doc)
(toNullable $ pgInt4 1)
(toNullable $ pgDouble 1)
queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
queryAuthorsDoc :: Query (NodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))
queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNodeNgramsTable queryNgramsTable queryNodeNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
where
cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
cond12 (nodeNgram, doc) = _node_id doc
.== nng_node_id nodeNgram
.== _nnng_node1_id nodeNgram
cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
cond23 (ngrams, (nodeNgram, _)) = ngrams^.ngrams_id
.== nng_ngrams_id nodeNgram
.== _nnng_ngrams_id nodeNgram
cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams^.ngrams_id .== nng_ngrams_id nodeNgram2
cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column PGBool
cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams^.ngrams_id .== _nnng_ngrams_id nodeNgram2
cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== nng_node_id nodeNgram2
cond45 :: (NodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column PGBool
cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== _nnng_node1_id nodeNgram2
-}
--}
------------------------------------------------------------------------
-- TODO-SECURITY check
......@@ -265,8 +274,12 @@ viewDocuments cId t ntId = proc () -> do
restrict -< n^.node_typename .== (pgInt4 ntId)
restrict -< if t then nn^.nn_category .== (pgInt4 0)
else nn^.nn_category .>= (pgInt4 1)
returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (toNullable $ nn^.nn_category) (toNullable $ nn^.nn_score)
returnA -< FacetDoc (_node_id n)
(_node_date n)
(_node_name n)
(_node_hyperdata n)
(toNullable $ nn^.nn_category)
(toNullable $ nn^.nn_score)
------------------------------------------------------------------------
filterWith :: (PGOrd date, PGOrd title, PGOrd score, hyperdata ~ Column SqlJsonb) =>
......
src/Gargantext/Database/Flow/Pairing.hs
View file @ 51513857
......@@ -52,11 +52,11 @@ pairing' = undefined
-}
-- | TODO : add paring policy as parameter
pairing :: AnnuaireId
-> CorpusId
pairing :: CorpusId -- (CorpusId, ListId) -- Pair (Either CorpusId AnnuaireId) ListId
-> AnnuaireId -- (AnnuaireId, ListId) -- Pair (Either CorpusId AnnuaireId) ListId
-> ListId
-> Cmd err Int
pairing aId cId lId = do
pairing cId aId lId = do
contacts' <- getAllContacts aId
let contactsMap = pairingPolicyToMap toLower
$ toMaps extractNgramsT (tr_docs contacts')
......@@ -120,6 +120,7 @@ getNgramsTindexed corpusId ngramsType' = fromList
where
selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
JOIN node_node_ngrams occ ON occ.ngrams_id = n.id
-- JOIN node_node_ngrams2 occ ON occ.ngrams_id = n.id
JOIN nodes_nodes nn ON nn.node2_id = occ.node2_id
WHERE nn.node1_id = ?
......
src/Gargantext/Database/Metrics/NgramsByNode.hs
View file @ 51513857
......@@ -180,11 +180,11 @@ getOccByNgramsOnlyFast' cId lId nt tms = trace (show (cId, lId)) $
-> NgramsType
-> [Text]
-> Cmd err [(Text, Double)]
run cId' lId' _nt' tms' = runPGSQuery query
run cId' lId' nt' tms' = runPGSQuery query
( Values fields (DPS.Only <$> tms')
, cId'
, lId'
-- , ngramsTypeId nt'
, ngramsTypeId nt'
)
query :: DPS.Query
......@@ -194,9 +194,9 @@ getOccByNgramsOnlyFast' cId lId nt tms = trace (show (cId, lId)) $
JOIN ngrams ng ON nng.ngrams_id = ng.id
JOIN input_rows ir ON ir.terms = ng.terms
WHERE nng.node1_id = ? -- CorpusId
AND nng.node2_id = ?
-- AND nng.ngrams_type = ? -- NgramsTypeId
-- AND nn.category > 0
AND nng.node2_id = ? -- ListId
AND nng.ngrams_type = ? -- NgramsTypeId
-- AND nn.category > 0 -- TODO
GROUP BY ng.terms, nng.weight
|]
......@@ -278,15 +278,32 @@ queryNgramsOccurrencesOnlyByNodeUser' = [sql|
GROUP BY nng.node2_id, ng.terms
|]
------------------------------------------------------------------------
getNodesByNgramsOnlyUser :: NodeId -> [ListId] -> NgramsType -> [Text]
-> Cmd err (Map Text (Set NodeId))
getNodesByNgramsOnlyUser cId ls nt ngs =
Map.unionsWith (<>)
. map (fromListWith (<>) . map (second Set.singleton))
. map (fromListWith (<>)
. map (second Set.singleton))
<$> mapM (selectNgramsOnlyByNodeUser cId ls nt)
(splitEvery 1000 ngs)
getNgramsByNodeOnlyUser :: NodeId
-> [ListId]
-> NgramsType
-> [Text]
-> Cmd err (Map NodeId (Set Text))
getNgramsByNodeOnlyUser cId ls nt ngs =
Map.unionsWith (<>)
. map (fromListWith (<>)
. map (second Set.singleton))
. map (map swap)
<$> mapM (selectNgramsOnlyByNodeUser cId ls nt)
(splitEvery 1000 ngs)
------------------------------------------------------------------------
selectNgramsOnlyByNodeUser :: CorpusId -> [ListId] -> NgramsType -> [Text]
-> Cmd err [(Text, NodeId)]
selectNgramsOnlyByNodeUser cId ls nt tms =
......@@ -319,7 +336,6 @@ queryNgramsOnlyByNodeUser = [sql|
selectNgramsOnlyByNodeUser' :: CorpusId -> [ListId] -> NgramsType -> [Text]
-> Cmd err [(Text, Int)]
selectNgramsOnlyByNodeUser' cId ls nt tms =
......@@ -349,7 +365,6 @@ queryNgramsOnlyByNodeUser' = [sql|
getNgramsByDocOnlyUser :: NodeId -> [ListId] -> NgramsType -> [Text]
-> Cmd err (Map Text (Set NodeId))
getNgramsByDocOnlyUser cId ls nt ngs =
......
src/Gargantext/Database/Node/Document/Add.hs
View file @ 51513857
......@@ -75,7 +75,6 @@ prepare pId ns = map (\nId -> InputData pId nId) ns
------------------------------------------------------------------------
-- * Main Types used
data InputData = InputData { inNode1_id :: NodeId
, inNode2_id :: NodeId
} deriving (Show, Generic, Typeable)
......
src/Gargantext/Database/Node/Document/Insert.hs
View file @ 51513857
......@@ -135,7 +135,6 @@ instance InsertDb HyperdataContact
, (toField . toJSON) h
]
-- | Debug SQL function
--
-- to print rendered query (Debug purpose) use @formatQuery@ function.
......
src/Gargantext/Database/Schema/Ngrams.hs
View file @ 51513857
......@@ -41,8 +41,12 @@ import Database.PostgreSQL.Simple.ToRow (toRow)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import GHC.Generics (Generic)
import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery, formatPGSQuery)
import Gargantext.Core.Types (TODO(..))
import Gargantext.Prelude
import Opaleye hiding (FromField)
import Servant (FromHttpApiData, parseUrlPiece, Proxy(..))
import Text.Read (read)
import Data.Swagger (ToParamSchema, toParamSchema)
import Prelude (Enum, Bounded, minBound, maxBound, Functor)
import qualified Database.PostgreSQL.Simple as PGS
......@@ -94,7 +98,7 @@ dbGetNgramsDb = runOpaQuery queryNgramsTable
-- ngrams in authors field of document has Authors Type
-- ngrams in text (title or abstract) of documents has Terms Type
data NgramsType = Authors | Institutes | Sources | NgramsTerms
deriving (Eq, Show, Ord, Enum, Bounded, Generic)
deriving (Eq, Show, Read, Ord, Enum, Bounded, Generic)
instance FromJSON NgramsType
instance FromJSONKey NgramsType where
......@@ -115,6 +119,15 @@ instance FromField NgramsTypeId where
if (n :: Int) > 0 then return $ NgramsTypeId n
else mzero
instance FromHttpApiData NgramsType where
parseUrlPiece n = pure $ (read . cs) n
instance ToParamSchema NgramsType where
toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
instance QueryRunnerColumnDefault (Nullable PGInt4) NgramsTypeId
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
......
src/Gargantext/Database/Schema/Node.hs
View file @ 51513857
......@@ -530,13 +530,20 @@ arbitraryDashboard = HyperdataDashboard (Just "Preferences")
------------------------------------------------------------------------
node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
node nodeType name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgInt4 userId) (pgNodeId <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
node nodeType name hyperData parentId userId =
Node Nothing
(pgInt4 typeId)
(pgInt4 userId)
(pgNodeId <$> parentId)
(pgStrictText name)
Nothing
(pgJSONB $ cs $ encode hyperData)
where
typeId = nodeTypeId nodeType
-------------------------------
insertNodes :: [NodeWrite] -> Cmd err Int64
insertNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
insertNodesR ns = mkCmd $ \conn ->
......@@ -576,10 +583,10 @@ data Node' = Node' { _n_type :: NodeType
} deriving (Show)
mkNodes :: [NodeWrite] -> Cmd err Int64
mkNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
mkNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
mkNodeR ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
------------------------------------------------------------------------
......
src/Gargantext/Database/Schema/NodeNode.hs
View file @ 51513857
......@@ -65,7 +65,7 @@ type NodeNodeReadNull = NodeNodePoly (Column (Nullable PGInt4))
(Column (Nullable PGFloat8))
(Column (Nullable PGInt4))
type NodeNode = NodeNodePoly Int Int (Maybe Double) (Maybe Int)
type NodeNode = NodeNodePoly NodeId NodeId (Maybe Double) (Maybe Int)
$(makeAdaptorAndInstance "pNodeNode" ''NodeNodePoly)
makeLenses ''NodeNodePoly
......@@ -102,8 +102,30 @@ instance QueryRunnerColumnDefault PGFloat8 (Maybe Double) where
instance QueryRunnerColumnDefault PGInt4 (Maybe Int) where
queryRunnerColumnDefault = fieldQueryRunnerColumn
------------------------------------------------------------------------
-- | Basic NodeNode tools
getNodeNode :: NodeId -> Cmd err [NodeNode]
getNodeNode n = runOpaQuery (selectNodeNode $ pgNodeId n)
where
selectNodeNode :: Column PGInt4 -> Query NodeNodeRead
selectNodeNode n' = proc () -> do
ns <- queryNodeNodeTable -< ()
restrict -< _nn_node1_id ns .== n'
returnA -< ns
-------------------------
insertNodeNode :: [NodeNode] -> Cmd err Int64
insertNodeNode ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeNodeTable ns' rCount Nothing
where
ns' :: [NodeNodeWrite]
ns' = map (\(NodeNode n1 n2 x y)
-> NodeNode (pgNodeId n1)
(pgNodeId n2)
(pgDouble <$> x)
(pgInt4 <$> y)
) ns
-- | Favorite management
nodeNodeCategory :: CorpusId -> DocId -> Int -> Cmd err [Int]
nodeNodeCategory cId dId c = map (\(PGS.Only a) -> a) <$> runPGSQuery favQuery (c,cId,dId)
......@@ -131,13 +153,11 @@ nodeNodesCategory inputData = map (\(PGS.Only a) -> a)
------------------------------------------------------------------------
-- | TODO use UTCTime fast
selectDocsDates :: CorpusId -> Cmd err [Text]
selectDocsDates cId =
map (head' "selectDocsDates" . splitOn "-")
selectDocsDates cId = map (head' "selectDocsDates" . splitOn "-")
<$> catMaybes
<$> map (view hyperdataDocument_publication_date)
<$> selectDocs cId
selectDocs :: CorpusId -> Cmd err [HyperdataDocument]
selectDocs cId = runOpaQuery (queryDocs cId)
......@@ -149,7 +169,6 @@ queryDocs cId = proc () -> do
restrict -< n^.node_typename .== (pgInt4 $ nodeTypeId NodeDocument)
returnA -< view (node_hyperdata) n
selectDocNodes :: CorpusId -> Cmd err [Node HyperdataDocument]
selectDocNodes cId = runOpaQuery (queryDocNodes cId)
......@@ -161,14 +180,12 @@ queryDocNodes cId = proc () -> do
restrict -< n^.node_typename .== (pgInt4 $ nodeTypeId NodeDocument)
returnA -< n
joinInCorpus :: O.Query (NodeRead, NodeNodeReadNull)
joinInCorpus = leftJoin queryNodeTable queryNodeNodeTable cond
where
cond :: (NodeRead, NodeNodeRead) -> Column PGBool
cond (n, nn) = nn^.nn_node2_id .== (view node_id n)
------------------------------------------------------------------------
-- | Trash management
nodeToTrash :: CorpusId -> DocId -> Bool -> Cmd err [PGS.Only Int]
......
src/Gargantext/Database/Schema/NodeNodeNgrams.hs
View file @ 51513857
......@@ -78,6 +78,8 @@ nodeNodeNgramsTable = Table "node_node_ngrams"
}
)
------------------------------------------------
queryNodeNodeNgramsTable :: Query NodeNodeNgramsRead
queryNodeNodeNgramsTable = queryTable nodeNodeNgramsTable
......
src/Gargantext/Database/Schema/NodesNgramsRepo.hs
View file @ 51513857
......@@ -80,7 +80,7 @@ selectPatches = proc () -> do
insertRepos :: [NgramsStatePatch] -> Cmd err Int64
insertRepos ns = mkCmd $ \conn -> runInsertMany conn repoTable (toWrite ns)
insertRepos ns = mkCmd $ \conn -> runInsert_ conn $ Insert repoTable (toWrite ns) rCount Nothing
where
toWrite :: [NgramsStatePatch] -> [RepoDbWrite]
toWrite = undefined
......
src/Gargantext/Database/Schema/User.hs
View file @ 51513857
......@@ -115,7 +115,9 @@ userTable = Table "auth_user" (pUser User { user_id = optional "id"
-- TODO: on conflict, nice message
insertUsers :: [UserWrite] -> Cmd err Int64
insertUsers us = mkCmd $ \c -> runInsertMany c userTable us
insertUsers us = mkCmd $ \c -> runInsert_ c insert
where
insert = Insert userTable us rCount Nothing
gargantextUser :: Username -> UserWrite
......
src/Gargantext/Database/Tree.hs
View file @ 51513857
......@@ -108,7 +108,7 @@ dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
FROM nodes AS c
INNER JOIN tree AS s ON c.parent_id = s.id
WHERE c.typename IN (2,20,21,22,3,5,30,31,40,7,9,90)
WHERE c.typename IN (2,20,21,22,3,5,30,31,40,7,9,90,71)
)
SELECT * from tree;
|] (Only rootId)
......
src/Gargantext/Database/Types/Node.hs
View file @ 51513857
......@@ -106,7 +106,6 @@ type Node json = NodePoly NodeId NodeTypeId UserId (Maybe ParentId) NodeName U
------------------------------------------------------------------------
instance FromHttpApiData NodeId where
parseUrlPiece n = pure $ NodeId $ (read . cs) n
......
src/Gargantext/Prelude/Utils.hs
View file @ 51513857
......@@ -36,12 +36,11 @@ import Crypto.Argon2 as Crypto
import Data.Either
import Data.ByteString.Base64.URL as URL
--------------------------------------------------------------------------
shuffle :: MonadRandom m => [a] -> m [a]
shuffle ns = SRS.shuffleM ns
type FolderPath = FilePath
type FileName = FilePath
--------------------------------------------------------------------------
sha :: Text -> Text
sha = Text.pack
. SHA.showDigest
......@@ -49,6 +48,7 @@ sha = Text.pack
. Char.pack
. Text.unpack
--------------------------------------------------------------------------
data NodeToHash = NodeToHash { nodeType :: NodeType
, nodeId :: NodeId
}
......@@ -58,6 +58,9 @@ secret_key = "WRV5ymit8s~ge6%08dLR7Q!gBcpb1MY%7e67db2206"
type SecretKey = ByteString
type FolderPath = FilePath
type FileName = FilePath
hashNode :: SecretKey -> NodeToHash -> ByteString
hashNode sk (NodeToHash nt ni) = case hashResult of
Left e -> panic (cs $ show e)
......
src/Gargantext/Viz/Phylo/API.hs
View file @ 51513857
......@@ -37,7 +37,7 @@ import Gargantext.Prelude
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Main
import Gargantext.Viz.Phylo.Example
import Gargantext.API.Ngrams (TODO(..))
import Gargantext.Core.Types (TODO(..))
import Servant
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
......
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