Skip to content

haskell-gargantext
haskell-gargantext
Commit 7c6cdb15 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

Merge remote-tracking branch 'origin/272-dev-fixes-for-node-score' into dev

parents 5983053e d16dd1e7
Hide whitespace changes
Inline Side-by-side
Showing with 496 additions and 404 deletions
gargantext.cabal
View file @ 7c6cdb15
......@@ -62,11 +62,13 @@ library
Gargantext.API.Node.Corpus.Update
Gargantext.API.Node.File
Gargantext.API.Node.Share
Gargantext.API.Node.Update
Gargantext.API.Prelude
Gargantext.API.Routes
Gargantext.Core
Gargantext.Core.NLP
Gargantext.Core.Mail.Types
Gargantext.Core.Methods.Similarities
Gargantext.Core.NLP
Gargantext.Core.NodeStory
Gargantext.Core.Text
Gargantext.Core.Text.Context
......@@ -193,7 +195,6 @@ library
Gargantext.API.Node.Get
Gargantext.API.Node.New
Gargantext.API.Node.Types
Gargantext.API.Node.Update
Gargantext.API.Public
Gargantext.API.Search
Gargantext.API.Server
......@@ -206,7 +207,6 @@ library
Gargantext.Core.Flow.Ngrams
Gargantext.Core.Flow.Types
Gargantext.Core.Mail
Gargantext.Core.Mail.Types
Gargantext.Core.Methods.Graph.BAC.Proxemy
Gargantext.Core.Methods.Graph.MaxClique
Gargantext.Core.Methods.Matrix.Accelerate.Utils
......@@ -941,6 +941,7 @@ test-suite garg-test-tasty
, crawlerArxiv
, duckling ^>= 0.2.0.0
, extra ^>= 1.7.9
, fast-logger ^>= 3.0.5
, fmt
, gargantext
, gargantext-prelude
......@@ -1044,6 +1045,7 @@ test-suite garg-test-hspec
, crawlerArxiv
, duckling ^>= 0.2.0.0
, extra ^>= 1.7.9
, fast-logger ^>= 3.0.5
, fmt
, gargantext
, gargantext-prelude
......
src/Gargantext/API/Admin/EnvTypes.hs
View file @ 7c6cdb15
......@@ -8,6 +8,7 @@ module Gargantext.API.Admin.EnvTypes (
GargJob(..)
, Env(..)
, Mode(..)
, modeToLoggingLevels
, mkJobHandle
, env_logger
, env_manager
......
src/Gargantext/API/Metrics.hs
View file @ 7c6cdb15
......@@ -26,6 +26,7 @@ import Gargantext.API.HashedResponse
import Gargantext.API.Ngrams.NgramsTree
import Gargantext.API.Ngrams.Types
import Gargantext.API.Prelude (GargServer)
import Gargantext.Core.NodeStory (HasNodeStory)
import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeLocal)
import Gargantext.Core.Types (CorpusId, ListId, ListType(..))
import Gargantext.Core.Types.Query (Limit)
......@@ -34,7 +35,6 @@ import Gargantext.Core.Viz.Types
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..), hl_chart, hl_pie, hl_scatter, hl_tree)
import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
......@@ -67,12 +67,12 @@ scatterApi id' = getScatter id'
:<|> updateScatter id'
:<|> getScatterHash id'
getScatter :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m (HashedResponse Metrics)
getScatter :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m (HashedResponse Metrics)
getScatter cId maybeListId tabType _maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
......@@ -84,32 +84,35 @@ getScatter cId maybeListId tabType _maybeLimit = do
chart <- case mChart of
Just chart -> pure chart
Nothing -> do
updateScatter' cId maybeListId tabType Nothing
updateScatter' cId listId tabType Nothing
pure $ constructHashedResponse chart
updateScatter :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m ()
updateScatter :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m ()
updateScatter cId maybeListId tabType maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
-- printDebug "[updateScatter] cId" cId
-- printDebug "[updateScatter] maybeListId" maybeListId
-- printDebug "[updateScatter] tabType" tabType
-- printDebug "[updateScatter] maybeLimit" maybeLimit
_ <- updateScatter' cId maybeListId tabType maybeLimit
_ <- updateScatter' cId listId tabType maybeLimit
pure ()
updateScatter' :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m Metrics
updateScatter' cId maybeListId tabType maybeLimit = do
(ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
updateScatter' :: HasNodeStory env err m
=> CorpusId
-> ListId
-> TabType
-> Maybe Limit
-> m Metrics
updateScatter' cId listId tabType maybeLimit = do
(ngs', scores) <- Metrics.getMetrics cId listId tabType maybeLimit
let
metrics = fmap (\(Scored t s1 s2) -> Metric { m_label = unNgramsTerm t
......@@ -120,9 +123,6 @@ updateScatter' cId maybeListId tabType maybeLimit = do
listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
errorMsg = "API.Node.metrics: key absent"
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
let hl = node ^. node_hyperdata
scatterMap = hl ^. hl_scatter
......@@ -130,11 +130,11 @@ updateScatter' cId maybeListId tabType maybeLimit = do
pure $ Metrics metrics
getScatterHash :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> m Text
getScatterHash :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> m Text
getScatterHash cId maybeListId tabType = do
hash <$> getScatter cId maybeListId tabType Nothing
......@@ -163,8 +163,8 @@ chartApi id' = getChart id'
:<|> getChartHash id'
-- TODO add start / end
getChart :: FlowCmdM env err m =>
CorpusId
getChart :: HasNodeStory env err m
=> CorpusId
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe ListId
......@@ -181,7 +181,7 @@ getChart cId _start _end maybeListId tabType = do
chart <- case mChart of
Just chart -> pure chart
Nothing -> do
updateChart' cId maybeListId tabType Nothing
updateChart' cId listId tabType Nothing
pure $ constructHashedResponse chart
......@@ -190,25 +190,25 @@ updateChart :: HasNodeError err =>
-> Maybe ListId
-> TabType
-> Maybe Limit
-> Cmd err ()
-> DBCmd err ()
updateChart cId maybeListId tabType maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
printDebug "[updateChart] cId" cId
printDebug "[updateChart] maybeListId" maybeListId
printDebug "[updateChart] listId" listId
printDebug "[updateChart] tabType" tabType
printDebug "[updateChart] maybeLimit" maybeLimit
_ <- updateChart' cId maybeListId tabType maybeLimit
_ <- updateChart' cId listId tabType maybeLimit
pure ()
updateChart' :: HasNodeError err =>
CorpusId
-> Maybe ListId
-> ListId
-> TabType
-> Maybe Limit
-> Cmd err (ChartMetrics Histo)
updateChart' cId maybeListId tabType _maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
-> DBCmd err (ChartMetrics Histo)
updateChart' cId listId tabType _maybeLimit = do
node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
let hl = node ^. node_hyperdata
chartMap = hl ^. hl_chart
......@@ -218,11 +218,11 @@ updateChart' cId maybeListId tabType _maybeLimit = do
pure $ ChartMetrics h
getChartHash :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> m Text
getChartHash :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> m Text
getChartHash cId maybeListId tabType = do
hash <$> getChart cId Nothing Nothing maybeListId tabType
......@@ -249,7 +249,7 @@ pieApi id' = getPie id'
:<|> updatePie id'
:<|> getPieHash id'
getPie :: FlowCmdM env err m
getPie :: HasNodeStory env err m
=> CorpusId
-> Maybe UTCTime
-> Maybe UTCTime
......@@ -271,12 +271,12 @@ getPie cId _start _end maybeListId tabType = do
pure $ constructHashedResponse chart
updatePie :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m ()
updatePie :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m ()
updatePie cId maybeListId tabType maybeLimit = do
printDebug "[updatePie] cId" cId
printDebug "[updatePie] maybeListId" maybeListId
......@@ -285,12 +285,12 @@ updatePie cId maybeListId tabType maybeLimit = do
_ <- updatePie' cId maybeListId tabType maybeLimit
pure ()
updatePie' :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m (ChartMetrics Histo)
updatePie' :: (HasNodeStory env err m, HasNodeError err)
=> CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m (ChartMetrics Histo)
updatePie' cId maybeListId tabType _maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
......@@ -304,11 +304,11 @@ updatePie' cId maybeListId tabType _maybeLimit = do
pure $ ChartMetrics p
getPieHash :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> m Text
getPieHash :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> m Text
getPieHash cId maybeListId tabType = do
hash <$> getPie cId Nothing Nothing maybeListId tabType
......@@ -338,7 +338,7 @@ treeApi id' = getTree id'
:<|> updateTree id'
:<|> getTreeHash id'
getTree :: FlowCmdM env err m
getTree :: HasNodeStory env err m
=> CorpusId
-> Maybe UTCTime
-> Maybe UTCTime
......@@ -362,12 +362,12 @@ getTree cId _start _end maybeListId tabType listType = do
pure $ constructHashedResponse chart
updateTree :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m ()
updateTree :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m ()
updateTree cId maybeListId tabType listType = do
printDebug "[updateTree] cId" cId
printDebug "[updateTree] maybeListId" maybeListId
......@@ -376,12 +376,12 @@ updateTree cId maybeListId tabType listType = do
_ <- updateTree' cId maybeListId tabType listType
pure ()
updateTree' :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m (ChartMetrics (Vector NgramsTree))
updateTree' :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m (ChartMetrics (Vector NgramsTree))
updateTree' cId maybeListId tabType listType = do
listId <- case maybeListId of
Just lid -> pure lid
......@@ -395,11 +395,11 @@ updateTree' cId maybeListId tabType listType = do
pure $ ChartMetrics t
getTreeHash :: FlowCmdM env err m =>
CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m Text
getTreeHash :: HasNodeStory env err m
=> CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m Text
getTreeHash cId maybeListId tabType listType = do
hash <$> getTree cId Nothing Nothing maybeListId tabType listType
src/Gargantext/API/Ngrams.hs
View file @ 7c6cdb15
......@@ -108,7 +108,6 @@ import Gargantext.Core.NodeStory
import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, TODO, assertValid, HasInvalidError, ContextId)
import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
import Gargantext.API.Ngrams.Tools
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Metrics.NgramsByContext (getOccByNgramsOnlyFast)
import Gargantext.Database.Admin.Config (userMaster)
import Gargantext.Database.Admin.Types.Node (NodeType(..))
......@@ -418,8 +417,6 @@ tableNgramsPut tabType listId (Versioned p_version p_table)
tableNgramsPostChartsAsync :: ( HasNodeStory env err m
, FlowCmdM env err m
, HasNodeError err
, HasSettings env
, MonadJobStatus m
)
......@@ -471,7 +468,7 @@ tableNgramsPostChartsAsync utn jobHandle = do
-- printDebug "[tableNgramsPostChartsAsync] Terms, updating Metrics (Histo), cId" cId
markStarted 6 jobHandle
{-
_ <- Metrics.updateChart cId (Just listId) tabType Nothing
_ <- Metrics.updateChart cId listId tabType Nothing
logRefSuccess
_ <- Metrics.updatePie cId (Just listId) tabType Nothing
logRefSuccess
......
src/Gargantext/API/Node/Update.hs
View file @ 7c6cdb15
......@@ -16,28 +16,28 @@ Portability : POSIX
module Gargantext.API.Node.Update
where
--import Gargantext.Core.Types.Individu (User(..))
import Control.Lens (view)
import Data.Aeson
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Set qualified as Set
import Data.Swagger
import GHC.Generics (Generic)
import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import Gargantext.API.Admin.Types (HasSettings)
--import Gargantext.API.Ngrams.Types (TabType(..))
import Gargantext.API.Metrics qualified as Metrics
import Gargantext.API.Ngrams.Types qualified as NgramsTypes
import Gargantext.API.Prelude (GargM, GargError, simuLogs)
import Gargantext.Core.Methods.Similarities (GraphMetric(..))
import Gargantext.Core.NodeStory (HasNodeStory)
import Gargantext.Core.Types.Main (ListType(..))
import Gargantext.Core.Viz.Graph.API (recomputeGraph)
import Gargantext.Core.Viz.Graph.Tools (PartitionMethod(..), BridgenessMethod(..))
import Gargantext.Core.Viz.Graph.Types (Strength)
import Gargantext.Core.Viz.Phylo (PhyloSubConfigAPI(..), subConfigAPI2config)
import Gargantext.Core.Viz.Phylo.API.Tools (flowPhyloAPI)
-- import Gargantext.Database.Action.Mail (sendMail)
import Gargantext.Database.Action.Flow (reIndexWith)
import Gargantext.Database.Action.Flow.Pairing (pairing)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContextScore)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node
......@@ -46,15 +46,12 @@ import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Ngrams (NgramsType(NgramsTerms))
import Gargantext.Database.Schema.Node (node_parent_id)
import Gargantext.Prelude (Bool(..), Ord, Eq, (<$>), ($), {-printDebug,-} pure, show, cs, (<>), panic, (<*>))
import Gargantext.Utils.Aeson qualified as GUA
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import Prelude (Enum, Bounded, minBound, maxBound)
import Servant
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import qualified Data.Set as Set
import qualified Gargantext.API.Metrics as Metrics
import qualified Gargantext.API.Ngrams.Types as NgramsTypes
import qualified Gargantext.Utils.Aeson as GUA
------------------------------------------------------------------------
type API = Summary " Update node according to NodeType params"
......@@ -99,12 +96,12 @@ api uId nId =
serveJobsAPI UpdateNodeJob $ \jHandle p ->
updateNode uId nId p jHandle
updateNode :: (HasSettings env, FlowCmdM env err m, MonadJobStatus m)
=> UserId
-> NodeId
-> UpdateNodeParams
-> JobHandle m
-> m ()
updateNode :: (HasNodeStory env err m, HasSettings env, MonadJobStatus m)
=> UserId
-> NodeId
-> UpdateNodeParams
-> JobHandle m
-> m ()
updateNode uId nId (UpdateNodeParamsGraph metric partitionMethod bridgeMethod strength nt1 nt2) jobHandle = do
markStarted 2 jobHandle
......@@ -149,7 +146,7 @@ updateNode _uId lId (UpdateNodeParamsList _mode) jobHandle = do
_ <- case corpusId of
Just cId -> do
_ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
_ <- updateNgramsOccurrences cId (Just lId)
_ <- updateNgramsOccurrences cId lId
pure ()
Nothing -> pure ()
......@@ -181,24 +178,31 @@ updateNode _userId phyloId (UpdateNodePhylo config) jobHandle = do
updateNode _uId tId (UpdateNodeParamsTexts _mode) jobHandle = do
markStarted 3 jobHandle
corpusId <- view node_parent_id <$> getNode tId
lId <- defaultList $ fromMaybe (panic "[G.A.N.Update] updateNode/UpdateNodeParamsTexts: no defaultList") corpusId
markProgress 1 jobHandle
_ <- case corpusId of
Just cId -> do
_ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
_ <- updateNgramsOccurrences cId (Just lId)
_ <- updateContextScore cId (Just lId)
_ <- Metrics.updateChart cId (Just lId) NgramsTypes.Docs Nothing
-- printDebug "updateContextsScore" (cId, lId, u)
Just cId -> updateDocs cId
Nothing -> do
_ <- panic "[G.A.N.Update] updateNode/UpdateNodeParamsText: no corpus Id given"
pure ()
Nothing -> pure ()
markComplete jobHandle
updateNode _uId _nId _p jobHandle = do
simuLogs jobHandle 10
------------------------------------------------------------------------
updateDocs :: (HasNodeStory env err m)
=> NodeId -> m ()
updateDocs cId = do
lId <- defaultList cId
_ <- reIndexWith cId lId NgramsTerms (Set.singleton MapTerm)
_ <- updateNgramsOccurrences cId lId
_ <- updateContextScore cId lId
_ <- Metrics.updateChart' cId lId NgramsTypes.Docs Nothing
-- printDebug "updateContextsScore" (cId, lId, u)
pure ()
------------------------------------------------------------------------
-- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
......
src/Gargantext/API/Table.hs
View file @ 7c6cdb15
......@@ -133,7 +133,10 @@ getTableApi cId tabType mLimit mOffset mOrderBy mQuery mYear =
t <- getTable cId tabType mOffset mLimit mOrderBy mQuery mYear
pure $ constructHashedResponse t
postTableApi :: (CmdM env err m, MonadLogger m, HasNodeError err) => NodeId -> TableQuery -> m FacetTableResult
postTableApi :: (CmdM env err m, MonadLogger m, HasNodeError err)
=> NodeId
-> TableQuery
-> m FacetTableResult
postTableApi cId tq = case tq of
TableQuery o l order ft "" -> do
$(logLocM) DEBUG $ "New search with no query"
......@@ -170,7 +173,8 @@ searchInCorpus' cId t q o l order = do
Right boolQuery -> do
docs <- searchInCorpus cId t boolQuery o l order
countAllDocs <- searchCountInCorpus cId t boolQuery
pure $ TableResult { tr_docs = docs, tr_count = countAllDocs }
pure $ TableResult { tr_docs = docs
, tr_count = countAllDocs }
getTable :: HasNodeError err
......
src/Gargantext/Core/NLP.hs
View file @ 7c6cdb15
{-|
Module : Gargantext.Core.NLP
Description : GarganText NLP
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
module Gargantext.Core.NLP where
import Control.Lens (Getter, at, non)
......
src/Gargantext/Core/NodeStory.hs
View file @ 7c6cdb15
......@@ -117,7 +117,7 @@ import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (ListId, NodeId(..), NodeType)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Prelude (CmdM', HasConnectionPool(..), HasConfig)
import Gargantext.Database.Prelude (DbCmd', HasConnectionPool(..))
import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Prelude
......@@ -143,12 +143,10 @@ data NodeStoryEnv = NodeStoryEnv
}
deriving (Generic)
type HasNodeStory env err m = ( CmdM' env err m
type HasNodeStory env err m = ( DbCmd' env err m
, MonadReader env m
, MonadError err m
, HasNodeStoryEnv env
, HasConfig env
, HasConnectionPool env
, HasNodeError err
)
......
src/Gargantext/Core/Viz/Chart.hs
View file @ 7c6cdb15
......@@ -14,12 +14,15 @@ Portability : POSIX
module Gargantext.Core.Viz.Chart
where
import Data.HashMap.Strict qualified as HashMap
import Data.List (sortOn)
import Data.List qualified as List
import Data.Map.Strict (toList)
import qualified Data.List as List
import Data.Maybe (catMaybes)
import qualified Data.Vector as V
import Data.Vector qualified as V
import Gargantext.Core.NodeStory (HasNodeStory)
import Gargantext.Core.Text.Metrics.Count (occurrencesWith)
import Gargantext.Core.Types.Main
import Gargantext.Database.Admin.Config
import Gargantext.Database.Prelude
......@@ -28,21 +31,18 @@ import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Database.Query.Table.NodeContext (selectDocsDates)
import Gargantext.Database.Schema.Node
import Gargantext.Prelude
import Gargantext.Core.Text.Metrics.Count (occurrencesWith)
-- Pie Chart
import Gargantext.API.Ngrams.NgramsTree
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Metrics.NgramsByContext
import Gargantext.Database.Schema.Ngrams
import Gargantext.Core.Viz.Types
import qualified Data.HashMap.Strict as HashMap
histoData :: CorpusId -> Cmd err Histo
histoData :: CorpusId -> DBCmd err Histo
histoData cId = do
dates <- selectDocsDates cId
let (ls, css) = V.unzip
......@@ -53,9 +53,9 @@ histoData cId = do
pure (Histo ls css)
chartData :: FlowCmdM env err m
=> CorpusId -> NgramsType -> ListType
-> m Histo
chartData :: HasNodeStory env err m
=> CorpusId -> NgramsType -> ListType
-> m Histo
chartData cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId
......@@ -77,7 +77,7 @@ chartData cId nt lt = do
pure (Histo dates (round <$> count))
treeData :: FlowCmdM env err m
treeData :: HasNodeStory env err m
=> CorpusId -> NgramsType -> ListType
-> m (V.Vector NgramsTree)
treeData cId nt lt = do
......
src/Gargantext/Core/Viz/Graph/API.hs
View file @ 7c6cdb15
......@@ -34,11 +34,10 @@ import Gargantext.Core.Viz.Graph.GEXF ()
import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
import Gargantext.Core.Viz.Graph.Types
import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOnlyUser)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select
......@@ -83,8 +82,8 @@ graphAPI u n = getGraph u n
------------------------------------------------------------------------
--getGraph :: UserId -> NodeId -> GargServer HyperdataGraphAPI
getGraph :: FlowCmdM env err m
=> UserId
getGraph :: HasNodeStory env err m
=> UserId
-> NodeId
-> m HyperdataGraphAPI
getGraph _uId nId = do
......@@ -122,7 +121,7 @@ getGraph _uId nId = do
--recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
recomputeGraph :: FlowCmdM env err m
recomputeGraph :: HasNodeStory env err m
=> UserId
-> NodeId
-> PartitionMethod
......@@ -179,7 +178,7 @@ recomputeGraph _uId nId partitionMethod bridgeMethod maybeSimilarity maybeStreng
-- TODO remove repo
computeGraph :: FlowCmdM env err m
computeGraph :: HasNodeError err
=> CorpusId
-> PartitionMethod
-> BridgenessMethod
......@@ -187,7 +186,7 @@ computeGraph :: FlowCmdM env err m
-> Strength
-> (NgramsType, NgramsType)
-> NodeListStory
-> m Graph
-> DBCmd err Graph
computeGraph corpusId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo = do
-- Getting the Node parameters
lId <- defaultList corpusId
......@@ -230,7 +229,7 @@ defaultGraphMetadata :: HasNodeError err
-> NodeListStory
-> GraphMetric
-> Strength
-> Cmd err GraphMetadata
-> DBCmd err GraphMetadata
defaultGraphMetadata cId t repo gm str = do
lId <- defaultList cId
......@@ -265,7 +264,7 @@ graphAsync u n =
-- -> (JobLog -> GargNoServer ())
-- -> GargNoServer JobLog
-- TODO get Graph Metadata to recompute
graphRecompute :: (FlowCmdM env err m, MonadJobStatus m)
graphRecompute :: (HasNodeStory env err m, MonadJobStatus m)
=> UserId
-> NodeId
-> JobHandle m
......@@ -319,7 +318,7 @@ graphVersions n nId = do
, gv_repo = v }
--recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
recomputeVersions :: FlowCmdM env err m
recomputeVersions :: HasNodeStory env err m
=> UserId
-> NodeId
-> m Graph
......@@ -351,8 +350,8 @@ graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
--getGraphGexf :: UserId
-- -> NodeId
-- -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf :: FlowCmdM env err m
=> UserId
getGraphGexf :: HasNodeStory env err m
=> UserId
-> NodeId
-> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf uId nId = do
......
src/Gargantext/Core/Viz/Phylo/API/Tools.hs
View file @ 7c6cdb15
......@@ -16,35 +16,33 @@ module Gargantext.Core.Viz.Phylo.API.Tools
import Control.Lens hiding (Context)
import Data.Aeson (Value, decodeFileStrict, eitherDecode, encode)
import Data.ByteString.Lazy qualified as Lazy
import Data.Map.Strict (Map)
import Data.Proxy
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Proxy
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text, pack)
import Data.Time.Calendar (fromGregorian, diffGregorianDurationClip, cdMonths, diffDays, showGregorian)
import Data.Time.Clock.POSIX(posixSecondsToUTCTime)
import Gargantext.API.Ngrams.Prelude (getTermList)
import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.API.Prelude (GargNoServer)
import Gargantext.Core.Text.Terms.WithList (Patterns, buildPatterns, termsInText)
import Gargantext.Core (withDefaultLanguage, Lang)
import Gargantext.Core.NodeStory (HasNodeStory)
import Gargantext.Core.Text.Terms.WithList (Patterns, buildPatterns, termsInText)
import Gargantext.Core.Types (Context)
-- import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Main (ListType(MapTerm))
import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo)
import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo, toPhyloWithoutLink)
import Gargantext.Core.Viz.Phylo.PhyloTools ({-printIOMsg, printIOComment,-} setConfig)
-- import Gargantext.Database.Action.Flow (getOrMk_RootWithCorpus)
-- import Gargantext.Database.Admin.Config (userMaster)
-- import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
-- import Gargantext.Database.Action.Flow (getOrMk_RootWithCorpus)
-- import Gargantext.Database.Admin.Config (userMaster)
-- import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataPhylo(..), HyperdataCorpus(..))
import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
import Gargantext.Database.Admin.Types.Node (CorpusId, ContextId, PhyloId)
import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
import Gargantext.Database.Schema.Context
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
......@@ -53,21 +51,19 @@ import Gargantext.Prelude
import Prelude hiding (map)
import System.FilePath ((</>))
import System.IO.Temp (withTempDirectory)
import System.Process as Shell
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import System.Process qualified as Shell
--------------------------------------------------------------------
getPhyloData :: PhyloId -> GargNoServer (Maybe Phylo)
getPhyloData :: HasNodeError err
=> PhyloId -> DBCmd err (Maybe Phylo)
getPhyloData phyloId = do
nodePhylo <- getNodeWith phyloId (Proxy :: Proxy HyperdataPhylo)
pure $ _hp_data $ _node_hyperdata nodePhylo
putPhylo :: PhyloId -> GargNoServer Phylo
putPhylo :: PhyloId -> DBCmd err Phylo
putPhylo = undefined
savePhylo :: PhyloId -> GargNoServer ()
savePhylo :: PhyloId -> DBCmd err ()
savePhylo = undefined
--------------------------------------------------------------------
......@@ -93,7 +89,8 @@ phylo2dot2json phylo = do
Just v -> pure v
flowPhyloAPI :: PhyloConfig -> CorpusId -> GargNoServer Phylo
flowPhyloAPI :: (HasNodeStory env err m, HasNodeError err)
=> PhyloConfig -> CorpusId -> m Phylo
flowPhyloAPI config cId = do
corpus <- corpusIdtoDocuments (timeUnit config) cId
let phyloWithCliques = toPhyloWithoutLink corpus config
......@@ -103,7 +100,8 @@ flowPhyloAPI config cId = do
pure $ toPhylo $ setConfig config phyloWithCliques
--------------------------------------------------------------------
corpusIdtoDocuments :: TimeUnit -> CorpusId -> GargNoServer [Document]
corpusIdtoDocuments :: (HasNodeStory env err m, HasNodeError err)
=> TimeUnit -> CorpusId -> m [Document]
corpusIdtoDocuments timeUnit corpusId = do
docs <- selectDocNodes corpusId
lId <- defaultList corpusId
......
src/Gargantext/Database/Action/Flow.hs
View file @ 7c6cdb15
......@@ -374,8 +374,8 @@ flowCorpusUser l user userCorpusId listId ctype mfslw = do
-- Annuaire Flow
-- _ <- mkAnnuaire rootUserId userId
_ <- reIndexWith userCorpusId listId NgramsTerms (Set.singleton MapTerm)
_ <- updateContextScore userCorpusId (Just listId)
_ <- updateNgramsOccurrences userCorpusId (Just listId)
_ <- updateContextScore userCorpusId listId
_ <- updateNgramsOccurrences userCorpusId listId
pure userCorpusId
......@@ -614,9 +614,7 @@ extractInsert docs = do
-- | Re-index documents of a corpus with ngrams in the list
reIndexWith :: ( HasNodeStory env err m
, FlowCmdM env err m
)
reIndexWith :: ( HasNodeStory env err m )
=> CorpusId
-> ListId
-> NgramsType
......
src/Gargantext/Database/Action/Flow/Pairing.hs
View file @ 7c6cdb15
......@@ -25,8 +25,8 @@ import Data.Set (Set)
import Data.Text (Text)
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.API.Prelude (GargNoServer)
import Gargantext.Core
import Gargantext.Core.NodeStory (HasNodeStory)
import Gargantext.Core.Text.Metrics.CharByChar (levenshtein)
import Gargantext.Core.Types (TableResult(..))
import Gargantext.Core.Types.Main
......@@ -38,6 +38,7 @@ import Gargantext.Database.Admin.Types.Node -- (AnnuaireId, CorpusId, ListId, Do
import Gargantext.Database.Query.Prelude (returnA, queryNodeNodeTable)
import Gargantext.Database.Query.Table.Node (defaultList)
import Gargantext.Database.Query.Table.Node.Children (getAllContacts)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername)
import Gargantext.Database.Query.Table.NodeContext_NodeContext (insertNodeContext_NodeContext)
import Gargantext.Database.Query.Table.NodeNode (insertNodeNode)
......@@ -68,7 +69,8 @@ isPairedWith nId nt = runOpaQuery (selectQuery nt nId)
returnA -< node^.node_id
-----------------------------------------------------------------------
pairing :: AnnuaireId -> CorpusId -> Maybe ListId -> GargNoServer [Int]
pairing :: (HasNodeStory env err m, HasNodeError err)
=> AnnuaireId -> CorpusId -> Maybe ListId -> m [Int]
pairing a c l' = do
l <- case l' of
Nothing -> defaultList c
......@@ -78,9 +80,10 @@ pairing a c l' = do
insertNodeContext_NodeContext $ prepareInsert c a dataPaired
dataPairing :: AnnuaireId
dataPairing :: HasNodeStory env err m
=> AnnuaireId
-> (CorpusId, ListId, NgramsType)
-> GargNoServer (HashMap ContactId (Set DocId))
-> m (HashMap ContactId (Set DocId))
dataPairing aId (cId, lId, ngt) = do
-- mc :: HM.HashMap ContactName (Set ContactId)
mc <- getNgramsContactId aId
......@@ -164,7 +167,7 @@ getClosest f (NgramsTerm from) candidates = fst <$> head scored
------------------------------------------------------------------------
getNgramsContactId :: AnnuaireId
-> Cmd err (HashMap ContactName (Set NodeId))
-> DBCmd err (HashMap ContactName (Set NodeId))
getNgramsContactId aId = do
contacts <- getAllContacts aId
-- printDebug "getAllContexts" (tr_count contacts)
......@@ -181,10 +184,11 @@ toName contact = NgramsTerm $ (Text.toTitle firstName) <> " " <> (Text.toTitle l
firstName = fromMaybe "" $ contact^.(node_hyperdata . hc_who . _Just . cw_firstName)
lastName = fromMaybe "" $ contact^.(node_hyperdata . hc_who . _Just . cw_lastName)
getNgramsDocId :: CorpusId
getNgramsDocId :: HasNodeStory env err m
=> CorpusId
-> ListId
-> NgramsType
-> GargNoServer (HashMap DocAuthor (Set NodeId))
-> m (HashMap DocAuthor (Set NodeId))
getNgramsDocId cId lId nt = do
lIds <- selectNodesWithUsername NodeList userMaster
repo <- getRepo (lId:lIds)
......
src/Gargantext/Database/Action/Metrics.hs
View file @ 7c6cdb15
......@@ -15,58 +15,50 @@ Node API
module Gargantext.Database.Action.Metrics
where
import Database.PostgreSQL.Simple.SqlQQ (sql)
-- import Gargantext.Database.Action.Metrics.NgramsByContext (refreshNgramsMaterialized)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.List qualified as List
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Vector (Vector)
import Database.PostgreSQL.Simple (Query, Only(..))
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.ToField (toField, Action{-, ToField-})
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Data.Vector (Vector)
import Gargantext.Core (HasDBid(toDBid))
import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo)
import Gargantext.Database.Prelude (runPGSQuery{-, formatPGSQuery-})
import Gargantext.API.Ngrams.Types (TabType(..), ngramsTypeFromTabType, NgramsTerm(..))
import Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Core (HasDBid(toDBid))
import Gargantext.Core.NodeStory hiding (runPGSQuery)
import Gargantext.Core.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-})
import Database.PostgreSQL.Simple.ToField (toField, Action{-, ToField-})
import Gargantext.Core.Types (ListType(..), NodeType(..), ContextId)
import Gargantext.Core.Types.Query (Limit(..))
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOnlyUser{-, getTficfWith-})
import Gargantext.Database.Admin.Config (userMaster)
-- import Gargantext.Database.Action.Metrics.NgramsByContext (refreshNgramsMaterialized)
import Gargantext.Database.Admin.Types.Node (ListId, CorpusId)
import Gargantext.Database.Query.Table.Node (defaultList)
import Gargantext.Database.Prelude (runPGSQuery{-, formatPGSQuery-})
import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Prelude
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.List as List
import qualified Data.Text as Text
getMetrics :: FlowCmdM env err m
=> CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-> m (HashMap NgramsTerm (ListType, Maybe NgramsTerm), Vector (Scored NgramsTerm))
getMetrics cId maybeListId tabType maybeLimit = do
(ngs, _, myCooc) <- getNgramsCooc cId maybeListId tabType maybeLimit
getMetrics :: (HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> Maybe Limit
-> m (HashMap NgramsTerm (ListType, Maybe NgramsTerm), Vector (Scored NgramsTerm))
getMetrics cId listId tabType maybeLimit = do
(ngs, _, myCooc) <- getNgramsCooc cId listId tabType maybeLimit
-- TODO HashMap
pure (ngs, scored myCooc)
getNgramsCooc :: (FlowCmdM env err m)
=> CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm)
, HashMap (NgramsTerm, NgramsTerm) Int
)
getNgramsCooc cId maybeListId tabType maybeLimit = do
lId <- case maybeListId of
Nothing -> defaultList cId
Just lId' -> pure lId'
getNgramsCooc :: (HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> Maybe Limit
-> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm)
, HashMap (NgramsTerm, NgramsTerm) Int
)
getNgramsCooc cId lId tabType maybeLimit = do
(ngs', ngs) <- getNgrams lId tabType
lIds <- selectNodesWithUsername NodeList userMaster
......@@ -81,22 +73,18 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do
------------------------------------------------------------------------
------------------------------------------------------------------------
updateNgramsOccurrences :: (FlowCmdM env err m)
=> CorpusId -> Maybe ListId
-> m ()
updateNgramsOccurrences cId mlId = do
_ <- mapM (updateNgramsOccurrences' cId mlId Nothing) [Terms, Sources, Authors, Institutes]
updateNgramsOccurrences :: (HasNodeStory env err m)
=> CorpusId -> ListId
-> m ()
updateNgramsOccurrences cId lId = do
_ <- mapM (updateNgramsOccurrences' cId lId Nothing) [Terms, Sources, Authors, Institutes]
pure ()
updateNgramsOccurrences' :: (FlowCmdM env err m)
=> CorpusId -> Maybe ListId -> Maybe Limit -> TabType
-> m [Int]
updateNgramsOccurrences' cId maybeListId maybeLimit tabType = do
lId <- case maybeListId of
Nothing -> defaultList cId
Just lId' -> pure lId'
updateNgramsOccurrences' :: (HasNodeStory env err m)
=> CorpusId -> ListId -> Maybe Limit -> TabType
-> m [Int]
updateNgramsOccurrences' cId lId maybeLimit tabType = do
result <- getNgramsOccurrences cId lId tabType maybeLimit
......@@ -136,16 +124,16 @@ updateNgramsOccurrences' cId maybeListId maybeLimit tabType = do
------------------------------------------------------------------------
-- Used for scores in Ngrams Table
getNgramsOccurrences :: (FlowCmdM env err m)
=> CorpusId -> ListId -> TabType -> Maybe Limit
-> m (HashMap NgramsTerm Int)
getNgramsOccurrences :: (HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> Maybe Limit
-> m (HashMap NgramsTerm Int)
getNgramsOccurrences c l t ml = HM.map Set.size <$> getNgramsContexts c l t ml
getNgramsContexts :: (FlowCmdM env err m)
=> CorpusId -> ListId -> TabType -> Maybe Limit
-> m (HashMap NgramsTerm (Set ContextId))
getNgramsContexts :: (HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> Maybe Limit
-> m (HashMap NgramsTerm (Set ContextId))
getNgramsContexts cId lId tabType maybeLimit = do
(_ngs', ngs) <- getNgrams lId tabType
lIds <- selectNodesWithUsername NodeList userMaster
......@@ -159,14 +147,10 @@ getNgramsContexts cId lId tabType maybeLimit = do
------------------------------------------------------------------------
updateContextScore :: (FlowCmdM env err m)
=> CorpusId -> Maybe ListId
-> m [Int]
updateContextScore cId maybeListId = do
lId <- case maybeListId of
Nothing -> defaultList cId
Just lId' -> pure lId'
updateContextScore :: (HasNodeStory env err m)
=> CorpusId -> ListId
-> m [Int]
updateContextScore cId lId = do
result <- getContextsNgramsScore cId lId Terms MapTerm Nothing
......@@ -200,15 +184,17 @@ updateContextScore cId maybeListId = do
-- Used for scores in Doc Table
getContextsNgramsScore :: (FlowCmdM env err m)
=> CorpusId -> ListId -> TabType -> ListType -> Maybe Limit
-> m (Map ContextId Int)
getContextsNgramsScore :: --(FlowCmdM env err m)
(HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> ListType -> Maybe Limit
-> m (Map ContextId Int)
getContextsNgramsScore cId lId tabType listType maybeLimit
= Map.map Set.size <$> getContextsNgrams cId lId tabType listType maybeLimit
getContextsNgrams :: (FlowCmdM env err m)
=> CorpusId -> ListId -> TabType -> ListType -> Maybe Limit
-> m (Map ContextId (Set NgramsTerm))
getContextsNgrams :: --(FlowCmdM env err m)
(HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> ListType -> Maybe Limit
-> m (Map ContextId (Set NgramsTerm))
getContextsNgrams cId lId tabType listType maybeLimit = do
(ngs', ngs) <- getNgrams lId tabType
lIds <- selectNodesWithUsername NodeList userMaster
......@@ -232,7 +218,7 @@ getContextsNgrams cId lId tabType listType maybeLimit = do
------------------------------------------------------------------------
getNgrams :: (HasMail env, HasNodeStory env err m)
getNgrams :: (HasNodeStory env err m)
=> ListId -> TabType
-> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm)
......
src/Gargantext/Database/Action/Metrics/Lists.hs
View file @ 7c6cdb15
......@@ -19,17 +19,17 @@ Portability : POSIX
module Gargantext.Database.Action.Metrics.Lists
where
import Gargantext.API.Ngrams.Types (TabType(..))
import Gargantext.Core.Text.Metrics (Scored(..))
import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
import Gargantext.Core.Types.Query (Limit)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Prelude hiding (sum, head)
import Prelude hiding (null, id, map, sum)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import qualified Data.Vector as Vec
import qualified Gargantext.Database.Action.Metrics as Metrics
-- import Gargantext.API.Ngrams.Types (TabType(..))
-- import Gargantext.Core.Text.Metrics (Scored(..))
-- import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
-- import Gargantext.Core.Types.Query (Limit)
-- import Gargantext.Database.Action.Flow.Types (FlowCmdM)
-- import Gargantext.Prelude hiding (sum, head)
-- import Prelude hiding (null, id, map, sum)
-- import qualified Data.HashMap.Strict as HashMap
-- import qualified Data.Map.Strict as Map
-- import qualified Data.Vector as Vec
-- import qualified Gargantext.Database.Action.Metrics as Metrics
{-
trainModel :: FlowCmdM env ServantErr m
=> Username -> m Score
......@@ -42,18 +42,18 @@ trainModel u = do
--}
getMetrics' :: FlowCmdM env err m
=> CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-> m (Map.Map ListType [Vec.Vector Double])
getMetrics' cId maybeListId tabType maybeLimit = do
(ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
-- getMetrics' :: FlowCmdM env err m
-- => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-- -> m (Map.Map ListType [Vec.Vector Double])
-- getMetrics' cId maybeListId tabType maybeLimit = do
-- (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
let
metrics = map (\(Scored t s1 s2) -> (listType t ngs', [Vec.fromList [s1,s2]])) scores
listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
errorMsg = "API.Node.metrics: key absent"
-- let
-- metrics = map (\(Scored t s1 s2) -> (listType t ngs', [Vec.fromList [s1,s2]])) scores
-- listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
-- errorMsg = "API.Node.metrics: key absent"
{-
_ <- Learn.grid 100 110 metrics' metrics'
--}
pure $ Map.fromListWith (<>) $ Vec.toList metrics
-- {-
-- _ <- Learn.grid 100 110 metrics' metrics'
-- --}
-- pure $ Map.fromListWith (<>) $ Vec.toList metrics
src/Gargantext/Database/Action/Metrics/NgramsByContext.hs
View file @ 7c6cdb15
......@@ -20,25 +20,25 @@ module Gargantext.Database.Action.Metrics.NgramsByContext
--import Data.Map.Strict.Patch (PatchMap, Replace, diff)
-- import Control.Monad (void)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.List qualified as List
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Tuple.Extra (first, second, swap)
import Database.PostgreSQL.Simple qualified as DPS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Database.PostgreSQL.Simple.Types qualified as DPST
import Gargantext.API.Ngrams.Types (NgramsTerm(..))
import Gargantext.Core
import Gargantext.Data.HashMap.Strict.Utils as HM
import Gargantext.Database.Admin.Types.Node (ListId, CorpusId, NodeId(..), ContextId, MasterCorpusId, NodeType(NodeDocument), UserCorpusId, DocId)
import Gargantext.Database.Prelude (Cmd, runPGSQuery) -- , execPGSQuery)
import Gargantext.Database.Prelude (DBCmd, runPGSQuery) -- , execPGSQuery)
import Gargantext.Database.Schema.Ngrams (ngramsTypeId, NgramsType(..))
import Gargantext.Prelude
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Database.PostgreSQL.Simple as DPS
import qualified Database.PostgreSQL.Simple.Types as DPST
-- | fst is size of Supra Corpus
-- snd is Texts and size of Occurrences (different docs)
......@@ -61,10 +61,10 @@ countContextsByNgramsWith f m = (total, m')
$ HM.toList m''
------------------------------------------------------------------------
getContextsByNgramsUser :: HasDBid NodeType
getContextsByNgramsUser :: HasDBid NodeType
=> CorpusId
-> NgramsType
-> Cmd err (HashMap NgramsTerm (Set ContextId))
-> DBCmd err (HashMap NgramsTerm (Set ContextId))
getContextsByNgramsUser cId nt =
HM.fromListWith (<>) <$> map (\(n,t) -> (NgramsTerm t, Set.singleton n))
<$> selectNgramsByContextUser cId nt
......@@ -73,7 +73,7 @@ getContextsByNgramsUser cId nt =
selectNgramsByContextUser :: HasDBid NodeType
=> CorpusId
-> NgramsType
-> Cmd err [(NodeId, Text)]
-> DBCmd err [(NodeId, Text)]
selectNgramsByContextUser cId' nt' =
runPGSQuery queryNgramsByContextUser
( cId'
......@@ -99,11 +99,11 @@ getContextsByNgramsUser cId nt =
------------------------------------------------------------------------
getOccByNgramsOnlyFast_withSample :: HasDBid NodeType
=> CorpusId
-> Int
-> NgramsType
-> [NgramsTerm]
-> Cmd err (HashMap NgramsTerm Int)
=> CorpusId
-> Int
-> NgramsType
-> [NgramsTerm]
-> DBCmd err (HashMap NgramsTerm Int)
getOccByNgramsOnlyFast_withSample cId int nt ngs =
HM.fromListWith (+) <$> selectNgramsOccurrencesOnlyByContextUser_withSample cId int nt ngs
......@@ -111,7 +111,7 @@ getOccByNgramsOnlyFast_withSample cId int nt ngs =
getOccByNgramsOnlyFast :: CorpusId
-> ListId
-> NgramsType
-> Cmd err (HashMap NgramsTerm [ContextId])
-> DBCmd err (HashMap NgramsTerm [ContextId])
getOccByNgramsOnlyFast cId lId nt = do
--HM.fromList <$> map (\(t,n) -> (NgramsTerm t, round n)) <$> run cId lId nt
HM.fromList <$> map (\(t, ns) -> (NgramsTerm t, NodeId <$> DPST.fromPGArray ns)) <$> run cId lId nt
......@@ -120,7 +120,7 @@ getOccByNgramsOnlyFast cId lId nt = do
run :: CorpusId
-> ListId
-> NgramsType
-> Cmd err [(Text, DPST.PGArray Int)]
-> DBCmd err [(Text, DPST.PGArray Int)]
run cId' lId' nt' = runPGSQuery query
( cId'
, lId'
......@@ -179,11 +179,11 @@ getOccByNgramsOnlyFast cId lId nt = do
selectNgramsOccurrencesOnlyByContextUser_withSample :: HasDBid NodeType
=> CorpusId
-> Int
-> NgramsType
-> [NgramsTerm]
-> Cmd err [(NgramsTerm, Int)]
=> CorpusId
-> Int
-> NgramsType
-> [NgramsTerm]
-> DBCmd err [(NgramsTerm, Int)]
selectNgramsOccurrencesOnlyByContextUser_withSample cId int nt tms =
fmap (first NgramsTerm) <$>
runPGSQuery queryNgramsOccurrencesOnlyByContextUser_withSample
......@@ -216,10 +216,10 @@ queryNgramsOccurrencesOnlyByContextUser_withSample = [sql|
|]
selectNgramsOccurrencesOnlyByContextUser_withSample' :: HasDBid NodeType
=> CorpusId
-> Int
-> NgramsType
-> Cmd err [(NgramsTerm, Int)]
=> CorpusId
-> Int
-> NgramsType
-> DBCmd err [(NgramsTerm, Int)]
selectNgramsOccurrencesOnlyByContextUser_withSample' cId int nt =
fmap (first NgramsTerm) <$>
runPGSQuery queryNgramsOccurrencesOnlyByContextUser_withSample
......@@ -253,7 +253,7 @@ getContextsByNgramsOnlyUser :: HasDBid NodeType
-> [ListId]
-> NgramsType
-> [NgramsTerm]
-> Cmd err (HashMap NgramsTerm (Set NodeId))
-> DBCmd err (HashMap NgramsTerm (Set NodeId))
getContextsByNgramsOnlyUser cId ls nt ngs =
HM.unionsWith (<>)
. map (HM.fromListWith (<>)
......@@ -262,11 +262,11 @@ getContextsByNgramsOnlyUser cId ls nt ngs =
(splitEvery 1000 ngs)
getNgramsByContextOnlyUser :: HasDBid NodeType
=> NodeId
-> [ListId]
-> NgramsType
-> [NgramsTerm]
-> Cmd err (Map NodeId (Set NgramsTerm))
=> NodeId
-> [ListId]
-> NgramsType
-> [NgramsTerm]
-> DBCmd err (Map NodeId (Set NgramsTerm))
getNgramsByContextOnlyUser cId ls nt ngs =
Map.unionsWith (<>)
. map ( Map.fromListWith (<>)
......@@ -282,7 +282,7 @@ selectNgramsOnlyByContextUser :: HasDBid NodeType
-> [ListId]
-> NgramsType
-> [NgramsTerm]
-> Cmd err [(NgramsTerm, ContextId)]
-> DBCmd err [(NgramsTerm, ContextId)]
selectNgramsOnlyByContextUser cId ls nt tms =
fmap (first NgramsTerm) <$>
runPGSQuery queryNgramsOnlyByContextUser
......@@ -317,7 +317,7 @@ getNgramsByDocOnlyUser :: DocId
-> [ListId]
-> NgramsType
-> [NgramsTerm]
-> Cmd err (HashMap NgramsTerm (Set NodeId))
-> DBCmd err (HashMap NgramsTerm (Set NodeId))
getNgramsByDocOnlyUser cId ls nt ngs =
HM.unionsWith (<>)
. map (HM.fromListWith (<>) . map (second Set.singleton))
......@@ -328,7 +328,7 @@ selectNgramsOnlyByDocUser :: DocId
-> [ListId]
-> NgramsType
-> [NgramsTerm]
-> Cmd err [(NgramsTerm, NodeId)]
-> DBCmd err [(NgramsTerm, NodeId)]
selectNgramsOnlyByDocUser dId ls nt tms =
fmap (first NgramsTerm) <$>
runPGSQuery queryNgramsOnlyByDocUser
......@@ -360,7 +360,7 @@ queryNgramsOnlyByDocUser = [sql|
getContextsByNgramsMaster :: HasDBid NodeType
=> UserCorpusId
-> MasterCorpusId
-> Cmd err (HashMap Text (Set NodeId))
-> DBCmd err (HashMap Text (Set NodeId))
getContextsByNgramsMaster ucId mcId = unionsWith (<>)
. map (HM.fromListWith (<>) . map (\(n,t) -> (t, Set.singleton n)))
-- . takeWhile (not . List.null)
......@@ -368,11 +368,11 @@ getContextsByNgramsMaster ucId mcId = unionsWith (<>)
<$> mapM (selectNgramsByContextMaster 1000 ucId mcId) [0,500..10000]
selectNgramsByContextMaster :: HasDBid NodeType
=> Int
-> UserCorpusId
-> MasterCorpusId
-> Int
-> Cmd err [(NodeId, Text)]
=> Int
-> UserCorpusId
-> MasterCorpusId
-> Int
-> DBCmd err [(NodeId, Text)]
selectNgramsByContextMaster n ucId mcId p = runPGSQuery
queryNgramsByContextMaster'
( ucId
......
src/Gargantext/Database/Query/Facet.hs
View file @ 7c6cdb15
......@@ -39,15 +39,12 @@ module Gargantext.Database.Query.Facet
import Control.Arrow (returnA)
import Control.Lens ((^.))
import qualified Data.Text as T
import Opaleye
import qualified Opaleye.Aggregate as OAgg
import Protolude hiding (null, map, sum, not)
import qualified Opaleye.Internal.Unpackspec()
import Data.Text qualified as T
import Gargantext.Core
import Gargantext.Core.Types
import Gargantext.Core.Types.Query (Limit, Offset, IsTrash)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Facet.Types
import Gargantext.Database.Query.Filter
import Gargantext.Database.Query.Table.Context
import Gargantext.Database.Query.Table.ContextNodeNgrams
......@@ -55,11 +52,13 @@ import Gargantext.Database.Query.Table.Ngrams
import Gargantext.Database.Query.Table.Node (defaultList)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.NodeContext (queryNodeContextTable)
import Gargantext.Database.Query.Facet.Types
import Gargantext.Database.Prelude
import Gargantext.Database.Schema.Context
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.NodeContext
import Opaleye
import Opaleye.Aggregate qualified as OAgg
import Opaleye.Internal.Unpackspec ()
import Protolude hiding (null, map, sum, not)
------------------------------------------------------------------------
......@@ -162,7 +161,7 @@ viewDocuments cId lId t ntId mQuery mYear =
, facetDoc_hyperdata = OAgg.groupBy
, facetDoc_category = OAgg.groupBy
, facetDoc_ngramCount = OAgg.sumInt4
, facetDoc_score = OAgg.sumInt4 })
, facetDoc_score = OAgg.groupBy })
(viewDocumentsAgg cId lId t ntId mQuery mYear)
viewDocumentsAgg :: CorpusId
......@@ -188,7 +187,7 @@ viewDocumentsAgg cId lId t ntId mQuery mYear = proc () -> do
-- currently it is all 0's in the DB and the
-- search functionality on the frontend orders
-- by Score.
, facetDoc_score = ngramCount
, facetDoc_score = unsafeCast "int8" $ nc ^. nc_score
}
-- TODO Join with context_node_ngrams at context_id/node_id and sum by
......
src/Gargantext/Database/Query/Facet/Types.hs
View file @ 7c6cdb15
......@@ -152,7 +152,7 @@ type FacetDocAggPart = Facet (Field SqlInt4 )
(Field SqlJsonb )
(Field SqlInt4) -- Category
(Field SqlInt4) -- Ngrams Count
(Field SqlInt4) -- Score
(Field SqlInt8) -- Score
-----------------------------------------------------------------------
-----------------------------------------------------------------------
......
src/Gargantext/Database/Query/Table/Node.hs
View file @ 7c6cdb15
{-|
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
......@@ -53,7 +52,7 @@ selectNode id' = proc () -> do
restrict -< _node_id row .== id'
returnA -< row
runGetNodes :: Select NodeRead -> Cmd err [Node HyperdataAny]
runGetNodes :: Select NodeRead -> DBCmd err [Node HyperdataAny]
runGetNodes = runOpaQuery
------------------------------------------------------------------------
......@@ -84,7 +83,7 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
returnA -< row ) -< ()
returnA -< node'
deleteNode :: NodeId -> Cmd err Int
deleteNode :: NodeId -> DBCmd err Int
deleteNode n = mkCmd $ \conn ->
fromIntegral <$> runDelete_ conn
(Delete nodeTable
......@@ -92,7 +91,7 @@ deleteNode n = mkCmd $ \conn ->
rCount
)
deleteNodes :: [NodeId] -> Cmd err Int
deleteNodes :: [NodeId] -> DBCmd err Int
deleteNodes ns = mkCmd $ \conn ->
fromIntegral <$> runDelete_ conn
(Delete nodeTable
......@@ -102,7 +101,7 @@ deleteNodes ns = mkCmd $ \conn ->
-- TODO: NodeType should match with `a'
getNodesWith :: (JSONB a, HasDBid NodeType) => NodeId -> proxy a -> Maybe NodeType
-> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
-> Maybe Offset -> Maybe Limit -> DBCmd err [Node a]
getNodesWith parentId _ nodeType maybeOffset maybeLimit =
runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
......@@ -110,7 +109,7 @@ getNodesWith parentId _ nodeType maybeOffset maybeLimit =
-- TODO: Why not use getNodesWith?
getNodesWithParentId :: (Hyperdata a, JSONB a)
=> Maybe NodeId
-> Cmd err [Node a]
-> DBCmd err [Node a]
getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
where
n' = case n of
......@@ -124,7 +123,7 @@ getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
getClosestParentIdByType :: HasDBid NodeType
=> NodeId
-> NodeType
-> Cmd err (Maybe NodeId)
-> DBCmd err (Maybe NodeId)
getClosestParentIdByType nId nType = do
result <- runPGSQuery query (PGS.Only nId)
case result of
......@@ -148,7 +147,7 @@ getClosestParentIdByType nId nType = do
getClosestParentIdByType' :: HasDBid NodeType
=> NodeId
-> NodeType
-> Cmd err (Maybe NodeId)
-> DBCmd err (Maybe NodeId)
getClosestParentIdByType' nId nType = do
result <- runPGSQuery query (PGS.Only nId)
case result of
......@@ -185,14 +184,14 @@ getChildrenByType nId nType = do
|]
------------------------------------------------------------------------
getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocumentV3]
getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataDocumentV3]
getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
-- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
getDocumentsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocument]
getDocumentsWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataDocument]
getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
getListsModelWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataModel]
getListsModelWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataModel]
getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
getCorporaWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataCorpus]
......@@ -209,7 +208,7 @@ selectNodesWithParentID n = proc () -> do
------------------------------------------------------------------------
-- | Example of use:
-- runCmdReplEasy (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType -> proxy a -> Cmd err [Node a]
getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType -> proxy a -> DBCmd err [Node a]
getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
where
selectNodesWithType :: HasDBid NodeType
......@@ -223,7 +222,7 @@ getNodeWithType :: (HasNodeError err, JSONB a, HasDBid NodeType)
=> NodeId
-> NodeType
-> proxy a
-> Cmd err [Node a]
-> DBCmd err [Node a]
getNodeWithType nId nt _ = runOpaQuery $ selectNodeWithType nId nt
where
selectNodeWithType :: HasDBid NodeType
......@@ -234,7 +233,7 @@ getNodeWithType nId nt _ = runOpaQuery $ selectNodeWithType nId nt
restrict -< tn .== sqlInt4 (toDBid nt')
returnA -< row
getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> Cmd err [NodeId]
getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> DBCmd err [NodeId]
getNodesIdWithType nt = do
ns <- runOpaQuery $ selectNodesIdWithType nt
pure (map NodeId ns)
......@@ -248,7 +247,7 @@ selectNodesIdWithType nt = proc () -> do
------------------------------------------------------------------------
nodeExists :: (HasNodeError err) => NodeId -> Cmd err Bool
nodeExists :: (HasNodeError err) => NodeId -> DBCmd err Bool
nodeExists nId = (== [PGS.Only True])
<$> runPGSQuery [sql|SELECT true FROM nodes WHERE id = ? |] (PGS.Only nId)
......@@ -317,7 +316,7 @@ insertNodes :: [NodeWrite] -> DBCmd err Int64
insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
{-
insertNodes' :: [Node a] -> Cmd err Int64
insertNodes' :: [Node a] -> DBCmd err Int64
insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
$ Insert nodeTable ns' rCount Nothing
where
......@@ -359,11 +358,11 @@ data Node' = Node' { _n_type :: NodeType
, _n_children :: [Node']
} deriving (Show)
mkNodes :: [NodeWrite] -> Cmd err Int64
mkNodes :: [NodeWrite] -> DBCmd err Int64
mkNodes ns = mkCmd $ \conn -> runInsert_ conn
$ Insert nodeTable ns rCount Nothing
mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
mkNodeR :: [NodeWrite] -> DBCmd err [NodeId]
mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
------------------------------------------------------------------------
......@@ -410,7 +409,7 @@ defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> DBCmd err Lis
defaultList cId =
maybe (nodeError (NoListFound cId)) (pure . view node_id) . headMay =<< getListsWithParentId cId
defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err (Maybe NodeId)
defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> DBCmd err (Maybe NodeId)
defaultListMaybe cId = headMay <$> map (view node_id ) <$> getListsWithParentId cId
getListsWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataList]
......
src/Gargantext/Database/Query/Table/Node/Children.hs
View file @ 7c6cdb15
......@@ -36,12 +36,12 @@ import Opaleye
-- TODO getAllTableDocuments
getAllDocuments :: HasDBid NodeType => ParentId -> Cmd err (TableResult (Node HyperdataDocument))
getAllDocuments :: HasDBid NodeType => ParentId -> DBCmd err (TableResult (Node HyperdataDocument))
getAllDocuments pId = getAllChildren pId (Proxy :: Proxy HyperdataDocument)
(Just NodeDocument)
-- TODO getAllTableContacts
getAllContacts :: HasDBid NodeType => ParentId -> Cmd err (TableResult (Node HyperdataContact))
getAllContacts :: HasDBid NodeType => ParentId -> DBCmd err (TableResult (Node HyperdataContact))
getAllContacts pId = getAllChildren pId (Proxy :: Proxy HyperdataContact)
(Just NodeContact)
......@@ -49,7 +49,7 @@ getAllChildren :: (JSONB a, HasDBid NodeType)
=> ParentId
-> proxy a
-> Maybe NodeType
-> Cmd err (NodeTableResult a)
-> DBCmd err (NodeTableResult a)
getAllChildren pId p maybeNodeType = getChildren pId p maybeNodeType Nothing Nothing
......@@ -59,7 +59,7 @@ getChildren :: (JSONB a, HasDBid NodeType)
-> Maybe NodeType
-> Maybe Offset
-> Maybe Limit
-> Cmd err (NodeTableResult a)
-> DBCmd err (NodeTableResult a)
getChildren pId p t@(Just NodeDocument) maybeOffset maybeLimit = getChildrenContext pId p t maybeOffset maybeLimit
getChildren pId p t@(Just NodeContact ) maybeOffset maybeLimit = getChildrenContext pId p t maybeOffset maybeLimit
getChildren a b c d e = getChildrenNode a b c d e
......@@ -71,7 +71,7 @@ getChildrenNode :: (JSONB a, HasDBid NodeType)
-> Maybe NodeType
-> Maybe Offset
-> Maybe Limit
-> Cmd err (NodeTableResult a)
-> DBCmd err (NodeTableResult a)
getChildrenNode pId _ maybeNodeType maybeOffset maybeLimit = do
-- printDebug "getChildrenNode" (pId, maybeNodeType)
let query = selectChildrenNode pId maybeNodeType
......@@ -97,12 +97,12 @@ selectChildrenNode parentId maybeNodeType = proc () -> do
getChildrenContext :: (JSONB a, HasDBid NodeType)
=> ParentId
-> proxy a
-> Maybe NodeType
-> Maybe Offset
-> Maybe Limit
-> Cmd err (NodeTableResult a)
=> ParentId
-> proxy a
-> Maybe NodeType
-> Maybe Offset
-> Maybe Limit
-> DBCmd err (NodeTableResult a)
getChildrenContext pId _ maybeNodeType maybeOffset maybeLimit = do
-- printDebug "getChildrenContext" (pId, maybeNodeType)
let query = selectChildren' pId maybeNodeType
......
src/Gargantext/Database/Query/Table/Node/Select.hs
View file @ 7c6cdb15
......@@ -27,7 +27,7 @@ import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.User
import Gargantext.Database.Query.Table.User
selectNodesWithUsername :: (HasDBid NodeType) => NodeType -> Username -> Cmd err [NodeId]
selectNodesWithUsername :: (HasDBid NodeType) => NodeType -> Username -> DBCmd err [NodeId]
selectNodesWithUsername nt u = runOpaQuery $ proc () -> do
n <- queryNodeTable -< ()
usrs <- optionalRestrict queryUserTable -<
......
src/Gargantext/Database/Query/Table/NodeContext.hs
View file @ 7c6cdb15
......@@ -70,12 +70,12 @@ queryNodeContextTable :: Select NodeContextRead
queryNodeContextTable = selectTable nodeContextTable
-- | not optimized (get all ngrams without filters)
_nodesContexts :: Cmd err [NodeContext]
_nodesContexts :: DBCmd err [NodeContext]
_nodesContexts = runOpaQuery queryNodeContextTable
------------------------------------------------------------------------
-- | Basic NodeContext tools
getNodeContexts :: NodeId -> Cmd err [NodeContext]
getNodeContexts :: NodeId -> DBCmd err [NodeContext]
getNodeContexts n = runOpaQuery (selectNodeContexts $ pgNodeId n)
where
selectNodeContexts :: Field SqlInt4 -> Select NodeContextRead
......@@ -85,7 +85,7 @@ getNodeContexts n = runOpaQuery (selectNodeContexts $ pgNodeId n)
returnA -< ns
getNodeContext :: HasNodeError err => ContextId -> NodeId -> Cmd err NodeContext
getNodeContext :: HasNodeError err => ContextId -> NodeId -> DBCmd err NodeContext
getNodeContext c n = do
maybeNodeContext <- headMay <$> runOpaQuery (selectNodeContext (pgNodeId c) (pgNodeId n))
case maybeNodeContext of
......@@ -99,7 +99,7 @@ getNodeContext c n = do
restrict -< _nc_node_id ns .== n'
returnA -< ns
updateNodeContextCategory :: ContextId -> NodeId -> Int -> Cmd err Int64
updateNodeContextCategory :: ContextId -> NodeId -> Int -> DBCmd err Int64
updateNodeContextCategory cId nId cat = do
execPGSQuery upScore (cat, cId, nId)
where
......@@ -120,7 +120,7 @@ data ContextForNgrams =
getContextsForNgrams :: HasNodeError err
=> NodeId
-> [Int]
-> Cmd err [ContextForNgrams]
-> DBCmd err [ContextForNgrams]
getContextsForNgrams cId ngramsIds = do
res <- runPGSQuery query (cId, PGS.In ngramsIds)
pure $ (\( _cfn_nodeId
......@@ -153,7 +153,7 @@ data ContextForNgramsTerms =
getContextsForNgramsTerms :: HasNodeError err
=> NodeId
-> [Text]
-> Cmd err [ContextForNgramsTerms]
-> DBCmd err [ContextForNgramsTerms]
getContextsForNgramsTerms cId ngramsTerms = do
res <- runPGSQuery query (cId, PGS.In ngramsTerms)
pure $ (\( _cfnt_nodeId
......@@ -180,15 +180,17 @@ getContextsForNgramsTerms cId ngramsTerms = do
date,
hyperdata,
nodes_contexts.score AS score,
nodes_contexts.category AS category,
context_node_ngrams.doc_count AS doc_count
nodes_contexts.category AS category --,
-- context_node_ngrams.doc_count AS doc_count
FROM contexts
JOIN context_node_ngrams ON contexts.id = context_node_ngrams.context_id
JOIN nodes_contexts ON contexts.id = nodes_contexts.context_id
JOIN ngrams ON context_node_ngrams.ngrams_id = ngrams.id
WHERE nodes_contexts.node_id = ?
AND ngrams.terms IN ?) t
ORDER BY t.doc_count DESC |]
-- ORDER BY t.doc_count DESC
ORDER BY t.score DESC
|]
......@@ -201,7 +203,7 @@ getContextsForNgramsTerms cId ngramsTerms = do
getContextNgrams :: HasNodeError err
=> NodeId
-> NodeId
-> Cmd err [Text]
-> DBCmd err [Text]
getContextNgrams contextId listId = do
res <- runPGSQuery query (contextId, listId)
pure $ (\(PGS.Only term) -> term) <$> res
......@@ -225,7 +227,7 @@ getContextNgrams contextId listId = do
getContextNgramsMatchingFTS :: HasNodeError err
=> NodeId
-> NodeId
-> Cmd err [Text]
-> DBCmd err [Text]
getContextNgramsMatchingFTS contextId listId = do
res <- runPGSQuery query (listId, contextId)
pure $ (\(PGS.Only term) -> term) <$> res
......@@ -254,7 +256,7 @@ getContextNgramsMatchingFTS contextId listId = do
AND (contexts.search @@ plainto_tsquery(ngrams.terms)
OR contexts.search @@ plainto_tsquery('french', ngrams.terms)) |]
------------------------------------------------------------------------
insertNodeContext :: [NodeContext] -> Cmd err Int
insertNodeContext :: [NodeContext] -> DBCmd err Int
insertNodeContext ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
$ Insert nodeContextTable ns' rCount (Just DoNothing))
where
......@@ -272,7 +274,7 @@ insertNodeContext ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
type Node_Id = NodeId
type Context_Id = NodeId
deleteNodeContext :: Node_Id -> Context_Id -> Cmd err Int
deleteNodeContext :: Node_Id -> Context_Id -> DBCmd err Int
deleteNodeContext n c = mkCmd $ \conn ->
fromIntegral <$> runDelete_ conn
(Delete nodeContextTable
......@@ -284,7 +286,7 @@ deleteNodeContext n c = mkCmd $ \conn ->
------------------------------------------------------------------------
-- | Favorite management
nodeContextsCategory :: [(CorpusId, DocId, Int)] -> Cmd err [Int]
nodeContextsCategory :: [(CorpusId, DocId, Int)] -> DBCmd err [Int]
nodeContextsCategory inputData = map (\(PGS.Only a) -> a)
<$> runPGSQuery catSelect (PGS.Only $ Values fields inputData)
where
......@@ -300,7 +302,7 @@ nodeContextsCategory inputData = map (\(PGS.Only a) -> a)
------------------------------------------------------------------------
-- | Score management
nodeContextsScore :: [(CorpusId, DocId, Int)] -> Cmd err [Int]
nodeContextsScore :: [(CorpusId, DocId, Int)] -> DBCmd err [Int]
nodeContextsScore inputData = map (\(PGS.Only a) -> a)
<$> runPGSQuery catScore (PGS.Only $ Values fields inputData)
where
......@@ -316,7 +318,7 @@ nodeContextsScore inputData = map (\(PGS.Only a) -> a)
------------------------------------------------------------------------
selectCountDocs :: HasDBid NodeType => CorpusId -> Cmd err Int
selectCountDocs :: HasDBid NodeType => CorpusId -> DBCmd err Int
selectCountDocs cId = runCountOpaQuery (queryCountDocs cId)
where
queryCountDocs cId' = proc () -> do
......@@ -328,13 +330,13 @@ selectCountDocs cId = runCountOpaQuery (queryCountDocs cId)
-- | TODO use UTCTime fast
selectDocsDates :: HasDBid NodeType => CorpusId -> Cmd err [Text]
selectDocsDates :: HasDBid NodeType => CorpusId -> DBCmd err [Text]
selectDocsDates cId = map (head' "selectDocsDates" . splitOn "-")
<$> catMaybes
<$> map (view hd_publication_date)
<$> selectDocs cId
selectDocs :: HasDBid NodeType => CorpusId -> Cmd err [HyperdataDocument]
selectDocs :: HasDBid NodeType => CorpusId -> DBCmd err [HyperdataDocument]
selectDocs cId = runOpaQuery (queryDocs cId)
queryDocs :: HasDBid NodeType => CorpusId -> O.Select (Field SqlJsonb)
......@@ -345,7 +347,7 @@ queryDocs cId = proc () -> do
restrict -< (c ^. context_typename) .== sqlInt4 (toDBid NodeDocument)
returnA -< view (context_hyperdata) c
selectDocNodes :: HasDBid NodeType => CorpusId -> Cmd err [Context HyperdataDocument]
selectDocNodes :: HasDBid NodeType => CorpusId -> DBCmd err [Context HyperdataDocument]
selectDocNodes cId = runOpaQuery (queryDocNodes cId)
queryDocNodes :: HasDBid NodeType => CorpusId -> O.Select ContextRead
......@@ -378,7 +380,7 @@ joinOn1 = proc () -> do
------------------------------------------------------------------------
selectPublicContexts :: HasDBid NodeType => (Hyperdata a, DefaultFromField SqlJsonb a)
=> Cmd err [(Node a, Maybe Int)]
=> DBCmd err [(Node a, Maybe Int)]
selectPublicContexts = runOpaQuery (queryWithType NodeFolderPublic)
queryWithType :: HasDBid NodeType => NodeType -> O.Select (NodeRead, MaybeFields (Field SqlInt4))
......
src/Gargantext/Database/Query/Table/NodeContext_NodeContext.hs
View file @ 7c6cdb15
......@@ -32,7 +32,7 @@ queryNodeContext_NodeContextTable :: Select NodeContext_NodeContextRead
queryNodeContext_NodeContextTable = selectTable nodeContext_NodeContextTable
-}
insertNodeContext_NodeContext :: [(CorpusId, DocId, AnnuaireId, ContactId)] -> Cmd err [Int]
insertNodeContext_NodeContext :: [(CorpusId, DocId, AnnuaireId, ContactId)] -> DBCmd err [Int]
insertNodeContext_NodeContext contexts = do
let
fields = map (\t -> QualifiedIdentifier Nothing t) $ snd fields_name
......
src/Gargantext/Database/Query/Table/NodeNode.hs
View file @ 7c6cdb15
......@@ -54,12 +54,12 @@ queryNodeNodeTable :: Select NodeNodeRead
queryNodeNodeTable = selectTable nodeNodeTable
-- | not optimized (get all ngrams without filters)
_nodesNodes :: Cmd err [NodeNode]
_nodesNodes :: DBCmd err [NodeNode]
_nodesNodes = runOpaQuery queryNodeNodeTable
------------------------------------------------------------------------
-- | Basic NodeNode tools
getNodeNode :: NodeId -> Cmd err [NodeNode]
getNodeNode :: NodeId -> DBCmd err [NodeNode]
getNodeNode n = runOpaQuery (selectNodeNode $ pgNodeId n)
where
selectNodeNode :: Column SqlInt4 -> Select NodeNodeRead
......@@ -71,7 +71,7 @@ getNodeNode n = runOpaQuery (selectNodeNode $ pgNodeId n)
------------------------------------------------------------------------
-- TODO (refactor with Children)
{-
getNodeNodeWith :: NodeId -> proxy a -> Maybe NodeType -> Cmd err [a]
getNodeNodeWith :: NodeId -> proxy a -> Maybe NodeType -> DBCmd err [a]
getNodeNodeWith pId _ maybeNodeType = runOpaQuery query
where
query = selectChildren pId maybeNodeType
......@@ -93,7 +93,7 @@ getNodeNodeWith pId _ maybeNodeType = runOpaQuery query
-}
------------------------------------------------------------------------
insertNodeNode :: [NodeNode] -> Cmd err Int
insertNodeNode :: [NodeNode] -> DBCmd err Int
insertNodeNode ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
$ Insert nodeNodeTable ns' rCount (Just DoNothing))
where
......@@ -111,7 +111,7 @@ insertNodeNode ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
type Node1_Id = NodeId
type Node2_Id = NodeId
deleteNodeNode :: Node1_Id -> Node2_Id -> Cmd err Int
deleteNodeNode :: Node1_Id -> Node2_Id -> DBCmd err Int
deleteNodeNode n1 n2 = mkCmd $ \conn ->
fromIntegral <$> runDelete_ conn
(Delete nodeNodeTable
......@@ -123,7 +123,7 @@ deleteNodeNode n1 n2 = mkCmd $ \conn ->
------------------------------------------------------------------------
-- | Favorite management
_nodeNodeCategory :: CorpusId -> DocId -> Int -> Cmd err [Int]
_nodeNodeCategory :: CorpusId -> DocId -> Int -> DBCmd err [Int]
_nodeNodeCategory cId dId c = map (\(PGS.Only a) -> a) <$> runPGSQuery favQuery (c,cId,dId)
where
favQuery :: PGS.Query
......@@ -132,7 +132,7 @@ _nodeNodeCategory cId dId c = map (\(PGS.Only a) -> a) <$> runPGSQuery favQuery
RETURNING node2_id;
|]
nodeNodesCategory :: [(CorpusId, DocId, Int)] -> Cmd err [Int]
nodeNodesCategory :: [(CorpusId, DocId, Int)] -> DBCmd err [Int]
nodeNodesCategory inputData = map (\(PGS.Only a) -> a)
<$> runPGSQuery catQuery (PGS.Only $ Values fields inputData)
where
......@@ -148,7 +148,7 @@ nodeNodesCategory inputData = map (\(PGS.Only a) -> a)
------------------------------------------------------------------------
-- | Score management
_nodeNodeScore :: CorpusId -> DocId -> Int -> Cmd err [Int]
_nodeNodeScore :: CorpusId -> DocId -> Int -> DBCmd err [Int]
_nodeNodeScore cId dId c = map (\(PGS.Only a) -> a) <$> runPGSQuery scoreQuery (c,cId,dId)
where
scoreQuery :: PGS.Query
......@@ -157,7 +157,7 @@ _nodeNodeScore cId dId c = map (\(PGS.Only a) -> a) <$> runPGSQuery scoreQuery (
RETURNING node2_id;
|]
nodeNodesScore :: [(CorpusId, DocId, Int)] -> Cmd err [Int]
nodeNodesScore :: [(CorpusId, DocId, Int)] -> DBCmd err [Int]
nodeNodesScore inputData = map (\(PGS.Only a) -> a)
<$> runPGSQuery catScore (PGS.Only $ Values fields inputData)
where
......@@ -172,7 +172,7 @@ nodeNodesScore inputData = map (\(PGS.Only a) -> a)
|]
------------------------------------------------------------------------
_selectCountDocs :: HasDBid NodeType => CorpusId -> Cmd err Int
_selectCountDocs :: HasDBid NodeType => CorpusId -> DBCmd err Int
_selectCountDocs cId = runCountOpaQuery (queryCountDocs cId)
where
queryCountDocs cId' = proc () -> do
......@@ -188,13 +188,13 @@ _selectCountDocs cId = runCountOpaQuery (queryCountDocs cId)
-- | TODO use UTCTime fast
selectDocsDates :: HasDBid NodeType => CorpusId -> Cmd err [Text]
selectDocsDates :: HasDBid NodeType => CorpusId -> DBCmd err [Text]
selectDocsDates cId = map (head' "selectDocsDates" . splitOn "-")
<$> catMaybes
<$> map (view hd_publication_date)
<$> selectDocs cId
selectDocs :: HasDBid NodeType => CorpusId -> Cmd err [HyperdataDocument]
selectDocs :: HasDBid NodeType => CorpusId -> DBCmd err [HyperdataDocument]
selectDocs cId = runOpaQuery (queryDocs cId)
queryDocs :: HasDBid NodeType => CorpusId -> O.Select (Column SqlJsonb)
......@@ -207,7 +207,7 @@ queryDocs cId = proc () -> do
restrict -< n ^. node_typename .== (sqlInt4 $ toDBid NodeDocument)
returnA -< view node_hyperdata n
selectDocNodes :: HasDBid NodeType =>CorpusId -> Cmd err [Node HyperdataDocument]
selectDocNodes :: HasDBid NodeType => CorpusId -> DBCmd err [Node HyperdataDocument]
selectDocNodes cId = runOpaQuery (queryDocNodes cId)
queryDocNodes :: HasDBid NodeType =>CorpusId -> O.Select NodeRead
......@@ -230,7 +230,7 @@ joinInCorpus = proc () -> do
------------------------------------------------------------------------
selectPublicNodes :: HasDBid NodeType => (Hyperdata a, DefaultFromField SqlJsonb a)
=> Cmd err [(Node a, Maybe Int)]
=> DBCmd err [(Node a, Maybe Int)]
selectPublicNodes = runOpaQuery (queryWithType NodeFolderPublic)
queryWithType :: HasDBid NodeType
......
test/Test/Database/Operations.hs
View file @ 7c6cdb15
......@@ -64,6 +64,7 @@ tests = sequential $ aroundAll withTestDB $ describe "Database" $ do
it "Can perform a simple search inside documents" corpusSearch01
it "Can perform search by author in documents" corpusSearch02
it "Can perform more complex searches using the boolean API" corpusSearch03
it "Can correctly count doc score" corpusScore01
data ExpectedActual a =
Expected a
......
test/Test/Database/Operations/DocumentSearch.hs
View file @ 7c6cdb15
{-|
Module : Test.Database.Operations.DocumentSearch
Description : GarganText database tests
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Test.Database.Operations.DocumentSearch where
import Prelude
import Control.Lens (view)
import Control.Monad.Reader
import Data.Aeson.QQ.Simple
import Data.Aeson.Types
import Data.Maybe
-- import Gargantext.API.Node.Update (updateDocs)
import Gargantext.Core
import Gargantext.Core.NLP (nlpServerGet)
import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.Flow
import Gargantext.Database.Action.Search
......@@ -16,7 +29,7 @@ import Gargantext.Database.Admin.Types.Hyperdata.Document
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Tree.Root
import Gargantext.Database.Schema.Node (NodePoly(..))
import Network.URI (parseURI)
-- import Network.URI (parseURI)
import Test.Database.Types
import Test.Hspec.Expectations
......@@ -104,11 +117,6 @@ exampleDocument_04 = either error id $ parseEither parseJSON $ [aesonQQ|
}
|]
nlpServerConfig :: NLPServerConfig
nlpServerConfig =
let uri = parseURI "http://localhost:9000"
in NLPServerConfig CoreNLP (fromMaybe (error "parseURI for nlpServerConfig failed") uri)
corpusAddDocuments :: TestEnv -> Assertion
corpusAddDocuments env = do
flip runReaderT env $ runTestMonad $ do
......@@ -118,9 +126,11 @@ corpusAddDocuments env = do
[corpus] <- getCorporaWithParentId parentId
let corpusId = _node_id corpus
ids <- addDocumentsToHyperCorpus nlpServerConfig
let lang = EN
server <- view (nlpServerGet lang)
ids <- addDocumentsToHyperCorpus server
(Just $ _node_hyperdata $ corpus)
(Multi EN)
(Multi lang)
corpusId
[exampleDocument_01, exampleDocument_02, exampleDocument_03, exampleDocument_04]
liftIO $ length ids `shouldBe` 4
......@@ -177,3 +187,24 @@ corpusSearch03 env = do
length results1 `shouldBe` 1
map facetDoc_title results2 `shouldBe` ["Haskell for OCaml programmers"]
map facetDoc_title results3 `shouldBe` ["PyPlasm: computational geometry made easy", "Haskell for OCaml programmers"]
-- | Check that the score doc count is correct
-- TODO This test is unfinished because `updateDocs` needs more work
corpusScore01 :: TestEnv -> Assertion
corpusScore01 env = do
flip runReaderT env $ runTestMonad $ do
parentId <- getRootId (UserName userMaster)
[corpus] <- getCorporaWithParentId parentId
results <- searchInCorpus (_node_id corpus) False (mkQ "Haskell") Nothing Nothing Nothing
liftIO $ do
map facetDoc_title results `shouldBe` ["Haskell for OCaml programmers", "Rust for functional programmers"]
map facetDoc_score results `shouldBe` [Just 0.0, Just 0.0]
-- _ <- updateDocs (_node_id corpus)
liftIO $ do
map facetDoc_score results `shouldBe` [Just 0.0, Just 0.0]
test/Test/Database/Setup.hs
View file @ 7c6cdb15
......@@ -10,20 +10,21 @@ import Control.Monad
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Pool hiding (withResource)
import Data.Pool qualified as Pool
import Data.String
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Database.PostgreSQL.Simple qualified as PG
import Database.PostgreSQL.Simple.Options qualified as Client
import Database.PostgreSQL.Simple.Options qualified as Opts
import Database.Postgres.Temp qualified as Tmp
import Gargantext.API.Admin.EnvTypes (Mode(Mock))
import Gargantext.Prelude.Config
import Gargantext.System.Logging (withLoggerHoisted)
import Paths_gargantext
import Prelude
import Shelly hiding (FilePath, run)
import qualified Data.Pool as Pool
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.Options as Client
import qualified Database.PostgreSQL.Simple.Options as Opts
import qualified Database.Postgres.Temp as Tmp
import qualified Shelly as SH
import Shelly qualified as SH
import Test.Database.Types
-- | Test DB settings.
......@@ -73,7 +74,8 @@ setup = do
(PG.close) 2 60 2
bootstrapDB db pool gargConfig
ugen <- emptyCounter
pure $ TestEnv (DBHandle pool db) gargConfig ugen
withLoggerHoisted Mock $ \logger -> do
pure $ TestEnv (DBHandle pool db) gargConfig ugen logger
withTestDB :: (TestEnv -> IO ()) -> IO ()
withTestDB = bracket setup teardown
......
test/Test/Database/Types.hs
View file @ 7c6cdb15
{-|
Module : Test.Database.Types
Description : GarganText tests
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
......@@ -10,18 +20,27 @@ import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.IORef
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
import Data.Pool
import Data.Text qualified as T
import Database.PostgreSQL.Simple qualified as PG
import Database.Postgres.Temp qualified as Tmp
import Gargantext
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.EnvTypes qualified as EnvTypes
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Prelude
import Gargantext.Core.Mail.Types (HasMail(..))
import Gargantext.Core.NLP (HasNLPServer(..))
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Prelude.Config
import Gargantext.Prelude.Mail.Types (MailConfig(..), LoginType(NoAuth))
import Gargantext.System.Logging (HasLogger(..), Logger, MonadLogger(..))
import Gargantext.Utils.Jobs
import Network.URI (parseURI)
import Prelude
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.Postgres.Temp as Tmp
import qualified Gargantext.API.Admin.EnvTypes as EnvTypes
import System.Log.FastLogger qualified as FL
newtype Counter = Counter { _Counter :: IORef Int }
deriving Eq
......@@ -39,6 +58,7 @@ data TestEnv = TestEnv {
test_db :: !DBHandle
, test_config :: !GargConfig
, test_usernameGen :: !Counter
, test_logger :: !(Logger (GargM TestEnv GargError))
}
newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
......@@ -79,3 +99,40 @@ instance HasConnectionPool TestEnv where
instance HasConfig TestEnv where
hasConfig = to test_config
instance HasMail TestEnv where
mailSettings = to $ const (MailConfig { _mc_mail_host = "localhost"
, _mc_mail_port = 25
, _mc_mail_user = "test"
, _mc_mail_from = "test@localhost"
, _mc_mail_password = "test"
, _mc_mail_login_type = NoAuth })
coreNLPConfig :: NLPServerConfig
coreNLPConfig =
let uri = parseURI "http://localhost:9000"
in NLPServerConfig CoreNLP (fromMaybe (error "parseURI for nlpServerConfig failed") uri)
instance HasNLPServer TestEnv where
nlpServer = to $ const (Map.singleton EN coreNLPConfig)
instance MonadLogger (GargM TestEnv GargError) where
getLogger = asks test_logger
instance HasLogger (GargM TestEnv GargError) where
data instance Logger (GargM TestEnv GargError) =
GargTestLogger {
test_logger_mode :: Mode
, test_logger_set :: FL.LoggerSet
}
type instance LogInitParams (GargM TestEnv GargError) = Mode
type instance LogPayload (GargM TestEnv GargError) = FL.LogStr
initLogger = \mode -> do
test_logger_set <- liftIO $ FL.newStderrLoggerSet FL.defaultBufSize
pure $ GargTestLogger mode test_logger_set
destroyLogger = \GargTestLogger{..} -> liftIO $ FL.rmLoggerSet test_logger_set
logMsg = \(GargTestLogger mode logger_set) lvl msg -> do
let pfx = "[" <> show lvl <> "] "
when (lvl `elem` (modeToLoggingLevels mode)) $
liftIO $ FL.pushLogStrLn logger_set $ FL.toLogStr pfx <> msg
logTxt lgr lvl msg = logMsg lgr lvl (FL.toLogStr $ T.unpack msg)
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