Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Christian Merten
haskell-gargantext
Commits
7da5cfa2
Commit
7da5cfa2
authored
Feb 15, 2019
by
Quentin Lobbé
Browse files
Options
Browse Files
Download
Plain Diff
Merge branch 'dev' into dev-phylo
parents
ce0f0e64
1f9f3f09
Changes
21
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
21 changed files
with
1132 additions
and
357 deletions
+1132
-357
Main.hs
bin/gargantext-import/Main.hs
+15
-7
Main.hs
bin/gargantext-server/Main.hs
+27
-30
package.yaml
package.yaml
+5
-0
API.hs
src/Gargantext/API.hs
+27
-14
Ngrams.hs
src/Gargantext/API/Ngrams.hs
+475
-74
Node.hs
src/Gargantext/API/Node.hs
+6
-3
Settings.hs
src/Gargantext/API/Settings.hs
+121
-16
Cooc.hs
src/Gargantext/Database/Cooc.hs
+4
-3
Flow.hs
src/Gargantext/Database/Flow.hs
+116
-75
Lists.hs
src/Gargantext/Database/Lists.hs
+65
-0
TFICF.hs
src/Gargantext/Database/Metrics/TFICF.hs
+0
-1
Ngrams.hs
src/Gargantext/Database/Schema/Ngrams.hs
+16
-13
Node.hs
src/Gargantext/Database/Schema/Node.hs
+67
-56
schema.sql
src/Gargantext/Database/Schema/schema.sql
+31
-8
Node.hs
src/Gargantext/Database/Types/Node.hs
+17
-22
Utils.hs
src/Gargantext/Database/Utils.hs
+12
-19
Flow.hs
src/Gargantext/Text/Flow.hs
+2
-1
Metrics.hs
src/Gargantext/Text/Metrics.hs
+1
-1
Phylo.hs
src/Gargantext/Viz/Phylo.hs
+14
-13
Tools.hs
src/Gargantext/Viz/Phylo/Tools.hs
+108
-0
stack.yaml
stack.yaml
+3
-1
No files found.
bin/gargantext-import/Main.hs
View file @
7da5cfa2
...
...
@@ -14,18 +14,21 @@ Import a corpus binary.
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Strict #-}
module
Main
where
import
Control.Exception
(
finally
)
import
Servant
(
ServantErr
)
import
Gargantext.Prelude
import
Gargantext.Database.Flow
(
flowCorpus
)
import
Gargantext.Database.Flow
(
FlowCmdM
,
flowCorpus
)
import
Gargantext.Text.Parsers
(
FileFormat
(
CsvHalFormat
))
import
Gargantext.Database.Utils
(
Cmd
,
connectGargandb
,
runCmdDevWith
)
import
Gargantext.Database.Types.Node
(
Node
Id
)
import
Gargantext.Database.Utils
(
Cmd
,
)
import
Gargantext.Database.Types.Node
(
Corpus
Id
)
--import Gargantext.Database.Schema.User (insertUsers, gargantuaUser, simpleUser)
import
Gargantext.API.Node
()
-- instances
import
Gargantext.API.Settings
(
newDevEnvWith
,
runCmdDev
,
DevEnv
)
import
System.Environment
(
getArgs
)
main
::
IO
()
...
...
@@ -34,11 +37,16 @@ main = do
{-let createUsers :: Cmd ServantErr Int64
createUsers = insertUsers [gargantuaUser,simpleUser]
_ <- runCmdDevWith iniPath createUsers
-}
let
cmd
::
Cmd
ServantErr
NodeId
cmd
=
flowCorpus
CsvHalFormat
corpusPath
(
cs
name
)
r
<-
runCmdDevWith
iniPath
cmd
let
cmdCorpus
::
forall
m
.
FlowCmdM
DevEnv
ServantErr
m
=>
m
CorpusId
cmdCorpus
=
flowCorpus
CsvHalFormat
corpusPath
(
cs
name
)
-- cmd = {-createUsers >>-} cmdCorpus
env
<-
newDevEnvWith
iniPath
-- Better if we keep only one call to runCmdDev.
_
<-
runCmdDev
env
cmdCorpus
pure
()
bin/gargantext-server/Main.hs
View file @
7da5cfa2
...
...
@@ -44,40 +44,37 @@ instance ParseField Mode
instance
ParseFields
Mode
data
MyOptions
w
=
MyOptions
{
run
::
w
:::
Mode
<?>
"Possible modes: Dev | Mock | Prod"
,
port
::
w
:::
Maybe
Int
<?>
"By default: 8008"
,
ini
::
w
:::
Maybe
Text
<?>
"Ini-file path of gargantext.ini"
}
deriving
(
Generic
)
data
MyOptions
w
=
MyOptions
{
run
::
w
:::
Mode
<?>
"Possible modes: Dev | Mock | Prod"
,
port
::
w
:::
Maybe
Int
<?>
"By default: 8008"
,
ini
::
w
:::
Maybe
Text
<?>
"Ini-file path of gargantext.ini"
}
deriving
(
Generic
)
instance
ParseRecord
(
MyOptions
Wrapped
)
deriving
instance
Show
(
MyOptions
Unwrapped
)
main
::
IO
()
main
=
do
MyOptions
myMode
myPort
myIniFile
<-
unwrapRecord
"Gargantext: collaborative platform for text-mining"
let
myPort'
=
case
myPort
of
Just
p
->
p
Nothing
->
8008
let
start
=
case
myMode
of
--Nothing -> startGargantext myPort' (unpack myIniFile')
Prod
->
startGargantext
myPort'
(
unpack
myIniFile'
)
where
myIniFile'
=
case
myIniFile
of
Nothing
->
panic
"For Prod mode, you need to fill a gargantext.ini file"
Just
i
->
i
Mock
->
startGargantextMock
myPort'
_
->
startGargantextMock
myPort'
putStrLn
$
"Starting Gargantext with mode: "
<>
show
myMode
start
-- main' :: IO ()
--main' = putStrLn $ show $ M.conditional $ M.myMat 10
main
=
do
MyOptions
myMode
myPort
myIniFile
<-
unwrapRecord
"Gargantext server"
let
myPort'
=
case
myPort
of
Just
p
->
p
Nothing
->
8008
let
start
=
case
myMode
of
Prod
->
startGargantext
myPort'
(
unpack
myIniFile'
)
where
myIniFile'
=
case
myIniFile
of
Nothing
->
panic
"[ERROR] gargantext.ini needed"
Just
i
->
i
_
->
startGargantextMock
myPort'
putStrLn
$
"Starting with "
<>
show
myMode
<>
" mode."
start
package.yaml
View file @
7da5cfa2
...
...
@@ -28,6 +28,7 @@ library:
-
Gargantext.API.Auth
-
Gargantext.API.Count
-
Gargantext.API.FrontEnd
-
Gargantext.API.Ngrams
-
Gargantext.API.Node
-
Gargantext.API.Orchestrator
-
Gargantext.API.Search
...
...
@@ -50,6 +51,7 @@ library:
-
Gargantext.Text.Examples
-
Gargantext.Text.List.CSV
-
Gargantext.Text.Metrics
-
Gargantext.Text.Metrics.TFICF
-
Gargantext.Text.Metrics.CharByChar
-
Gargantext.Text.Metrics.Count
-
Gargantext.Text.Parsers
...
...
@@ -109,6 +111,7 @@ library:
-
ini
-
insert-ordered-containers
-
jose-jwt
-
json-state
# - kmeans-vector
-
KMP
-
lens
...
...
@@ -159,11 +162,13 @@ library:
-
text-metrics
-
time
-
time-locale-compat
-
time-units
-
timezone-series
-
transformers
-
transformers-base
-
unordered-containers
-
uuid
-
validity
-
vector
-
wai
-
wai-cors
...
...
src/Gargantext/API.hs
View file @
7da5cfa2
...
...
@@ -44,6 +44,7 @@ import GHC.Generics (D1, Meta (..), Rep)
import
GHC.TypeLits
(
AppendSymbol
,
Symbol
)
import
Control.Lens
import
Control.Exception
(
finally
)
import
Control.Monad.IO.Class
(
liftIO
)
import
Control.Monad.Reader
(
runReaderT
)
import
Data.Aeson.Encode.Pretty
(
encodePretty
)
...
...
@@ -72,6 +73,7 @@ import Gargantext.Prelude
import
Gargantext.API.FrontEnd
(
FrontEndAPI
,
frontEndServer
)
import
Gargantext.API.Auth
(
AuthRequest
,
AuthResponse
,
auth
)
import
Gargantext.API.Ngrams
(
HasRepoVar
(
..
),
HasRepoSaver
(
..
),
saveRepo
)
import
Gargantext.API.Node
(
GargServer
,
Roots
,
roots
,
NodeAPI
,
nodeAPI
...
...
@@ -83,6 +85,7 @@ import Gargantext.API.Node ( GargServer
,
HyperdataAnnuaire
)
--import Gargantext.Database.Node.Contact (HyperdataContact)
import
Gargantext.Database.Utils
(
HasConnection
)
import
Gargantext.Database.Types.Node
(
NodeId
,
CorpusId
,
AnnuaireId
)
import
Gargantext.API.Count
(
CountAPI
,
count
,
Query
)
import
Gargantext.API.Search
(
SearchAPI
,
search
,
SearchQuery
)
...
...
@@ -163,9 +166,8 @@ makeMockApp env = do
makeDevApp
::
Env
->
IO
Application
makeDevApp
env
=
do
serverApp
<-
makeApp
env
makeDevMiddleware
::
IO
Middleware
makeDevMiddleware
=
do
-- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
--logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
...
...
@@ -192,8 +194,8 @@ makeDevApp env = do
--let warpS = Warp.setPort (8008 :: Int) -- (env^.settings.appPort)
-- $ Warp.defaultSettings
--pure (warpS, logWare
$ checkOriginAndHost $ corsMiddleware $ serverApp
)
pure
$
logStdoutDev
$
corsMiddleware
$
serverApp
--pure (warpS, logWare
. checkOriginAndHost . corsMiddleware
)
pure
$
logStdoutDev
.
corsMiddleware
---------------------------------------------------------------------
-- | API Global
...
...
@@ -276,12 +278,13 @@ type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html
---------------------------------------------------------------------
-- | Server declarations
server
::
Env
->
IO
(
Server
API
)
server
::
(
HasConnection
env
,
HasRepoVar
env
,
HasRepoSaver
env
)
=>
env
->
IO
(
Server
API
)
server
env
=
do
-- orchestrator <- scrapyOrchestrator env
pure
$
swaggerFront
:<|>
hoistServer
(
Proxy
::
Proxy
GargAPI
)
(`
runReaderT
`
env
)
serverGargAPI
:<|>
server
Index
:<|>
server
Static
serverGargAPI
::
GargServer
GargAPI
serverGargAPI
-- orchestrator
...
...
@@ -299,9 +302,12 @@ serverGargAPI -- orchestrator
where
fakeUserId
=
1
-- TODO
serverIndex
::
Server
(
Get
'[
H
TML
]
Html
)
serverIndex
=
$
(
do
(
Just
s
)
<-
liftIO
(
fileTypeToFileTree
(
FileTypeFile
"purescript-gargantext/dist/index.html"
))
fileTreeToServer
s
)
serverStatic
::
Server
(
Get
'[
H
TML
]
Html
)
serverStatic
=
$
(
do
let
path
=
"purescript-gargantext/dist/index.html"
Just
s
<-
liftIO
(
fileTypeToFileTree
(
FileTypeFile
path
))
fileTreeToServer
s
)
---------------------------------------------------------------------
swaggerFront
::
Server
SwaggerFrontAPI
...
...
@@ -312,11 +318,12 @@ gargMock :: Server GargAPI
gargMock
=
mock
apiGarg
Proxy
---------------------------------------------------------------------
makeApp
::
Env
->
IO
Application
makeApp
::
(
HasConnection
env
,
HasRepoVar
env
,
HasRepoSaver
env
)
=>
env
->
IO
Application
makeApp
=
fmap
(
serve
api
)
.
server
appMock
::
Application
appMock
=
serve
api
(
swaggerFront
:<|>
gargMock
:<|>
server
Index
)
appMock
=
serve
api
(
swaggerFront
:<|>
gargMock
:<|>
server
Static
)
---------------------------------------------------------------------
api
::
Proxy
API
...
...
@@ -367,13 +374,19 @@ portRouteInfo port = do
T
.
putStrLn
$
"http://localhost:"
<>
toUrlPiece
port
<>
"/index.html"
T
.
putStrLn
$
"http://localhost:"
<>
toUrlPiece
port
<>
"/swagger-ui"
stopGargantext
::
HasRepoSaver
env
=>
env
->
IO
()
stopGargantext
env
=
do
T
.
putStrLn
"----- Stopping gargantext -----"
runReaderT
saveRepo
env
-- | startGargantext takes as parameters port number and Ini file.
startGargantext
::
PortNumber
->
FilePath
->
IO
()
startGargantext
port
file
=
do
env
<-
newEnv
port
file
portRouteInfo
port
app
<-
makeDevApp
env
run
port
app
app
<-
makeApp
env
mid
<-
makeDevMiddleware
run
port
(
mid
app
)
`
finally
`
stopGargantext
env
startGargantextMock
::
PortNumber
->
IO
()
startGargantextMock
port
=
do
...
...
src/Gargantext/API/Ngrams.hs
View file @
7da5cfa2
This diff is collapsed.
Click to expand it.
src/Gargantext/API/Node.hs
View file @
7da5cfa2
...
...
@@ -46,7 +46,7 @@ import Data.Time (UTCTime)
import
GHC.Generics
(
Generic
)
import
Servant
import
Gargantext.API.Ngrams
(
TabType
(
..
),
TableNgramsApi
,
TableNgramsApiGet
,
tableNgramsPatch
,
getTableNgrams
)
import
Gargantext.API.Ngrams
(
TabType
(
..
),
TableNgramsApi
,
TableNgramsApiGet
,
tableNgramsPatch
,
getTableNgrams
,
HasRepoVar
,
HasRepoSaver
)
import
Gargantext.Prelude
import
Gargantext.Database.Types.Node
import
Gargantext.Database.Utils
-- (Cmd, CmdM)
...
...
@@ -72,7 +72,10 @@ import Gargantext.Database.Types.Node (CorpusId, ContactId)
import
Test.QuickCheck
(
elements
)
import
Test.QuickCheck.Arbitrary
(
Arbitrary
,
arbitrary
)
type
GargServer
api
=
forall
env
m
.
CmdM
env
ServantErr
m
=>
ServerT
api
m
type
GargServer
api
=
forall
env
m
.
(
CmdM
env
ServantErr
m
,
HasRepoVar
env
,
HasRepoSaver
env
)
=>
ServerT
api
m
-------------------------------------------------------------------
-- TODO-ACCESS: access by admin only.
...
...
@@ -279,7 +282,7 @@ graphAPI nId = do
nodeGraph
<-
getNode
nId
HyperdataGraph
let
title
=
"
Graph
Title"
let
title
=
"Title"
let
metadata
=
GraphMetadata
title
[
maybe
0
identity
$
_node_parentId
nodeGraph
]
[
LegendField
1
"#FFF"
"Cluster"
,
LegendField
2
"#FFF"
"Cluster"
...
...
src/Gargantext/API/Settings.hs
View file @
7da5cfa2
...
...
@@ -17,25 +17,31 @@ Portability : POSIX
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
module
Gargantext.API.Settings
where
import
System.Directory
import
System.Log.FastLogger
import
GHC.Enum
import
GHC.Generics
(
Generic
)
import
Prelude
(
Bounded
())
import
Prelude
(
Bounded
()
,
fail
)
import
System.Environment
(
lookupEnv
)
import
System.IO
(
FilePath
)
import
Database.PostgreSQL.Simple
(
Connection
,
connect
)
import
Network.HTTP.Client
(
Manager
)
import
Network.HTTP.Client.TLS
(
newTlsManager
)
import
Data.Aeson
import
Data.Maybe
(
fromMaybe
)
import
Data.Either
(
either
)
import
Data.JsonState
(
mkSaveState
)
import
Data.Text
import
Data.Text.Encoding
(
encodeUtf8
)
import
Data.Time.Units
import
Data.ByteString.Lazy.Internal
import
Servant
...
...
@@ -45,10 +51,14 @@ import Web.HttpApiData (parseUrlPiece)
import
qualified
Jose.Jwk
as
Jose
import
qualified
Jose.Jwa
as
Jose
import
Control.Concurrent
import
Control.Exception
(
finally
)
import
Control.Monad.Logger
import
Control.Monad.Reader
import
Control.Lens
import
Gargantext.Prelude
import
Gargantext.Database.Utils
(
databaseParameters
,
HasConnection
(
..
))
import
Gargantext.Database.Utils
(
databaseParameters
,
HasConnection
(
..
),
Cmd
'
,
runCmd
)
import
Gargantext.API.Ngrams
(
NgramsRepo
,
HasRepoVar
(
..
),
HasRepoSaver
(
..
),
initMockRepo
,
r_version
,
saveRepo
)
import
Gargantext.API.Orchestrator.Types
type
PortNumber
=
Int
...
...
@@ -125,12 +135,14 @@ optSetting name d = do
data
FireWall
=
FireWall
{
unFireWall
::
Bool
}
data
Env
=
Env
{
_env_settings
::
!
Settings
,
_env_logger
::
!
LoggerSet
,
_env_conn
::
!
Connection
,
_env_manager
::
!
Manager
,
_env_self_url
::
!
BaseUrl
,
_env_scrapers
::
!
ScrapersEnv
{
_env_settings
::
!
Settings
,
_env_logger
::
!
LoggerSet
,
_env_conn
::
!
Connection
,
_env_repo_var
::
!
(
MVar
NgramsRepo
)
,
_env_repo_saver
::
!
(
IO
()
)
,
_env_manager
::
!
Manager
,
_env_self_url
::
!
BaseUrl
,
_env_scrapers
::
!
ScrapersEnv
}
deriving
(
Generic
)
...
...
@@ -139,6 +151,12 @@ makeLenses ''Env
instance
HasConnection
Env
where
connection
=
env_conn
instance
HasRepoVar
Env
where
repoVar
=
env_repo_var
instance
HasRepoSaver
Env
where
repoSaver
=
env_repo_saver
data
MockEnv
=
MockEnv
{
_menv_firewall
::
!
FireWall
}
...
...
@@ -146,22 +164,109 @@ data MockEnv = MockEnv
makeLenses
''
M
ockEnv
repoSnapshot
::
FilePath
repoSnapshot
=
"repo.json"
readRepo
::
IO
(
MVar
NgramsRepo
)
readRepo
=
do
-- | Does file exist ? :: Bool
repoFile
<-
doesFileExist
repoSnapshot
-- | Is file not empty ? :: Bool
repoExists
<-
if
repoFile
then
(
>
0
)
<$>
getFileSize
repoSnapshot
else
pure
repoFile
newMVar
=<<
if
repoExists
then
do
e_repo
<-
eitherDecodeFileStrict
repoSnapshot
repo
<-
either
fail
pure
e_repo
let
archive
=
repoSnapshot
<>
".v"
<>
show
(
repo
^.
r_version
)
copyFile
repoSnapshot
archive
pure
repo
else
pure
initMockRepo
mkRepoSaver
::
MVar
NgramsRepo
->
IO
(
IO
()
)
mkRepoSaver
repo_var
=
do
saveAction
<-
mkSaveState
(
10
::
Second
)
repoSnapshot
pure
$
readMVar
repo_var
>>=
saveAction
newEnv
::
PortNumber
->
FilePath
->
IO
Env
newEnv
port
file
=
do
manager
<-
newTlsManager
settings
<-
pure
(
devSettings
&
appPort
.~
port
)
-- TODO read from 'file'
when
(
port
/=
settings
^.
appPort
)
$
panic
"TODO: conflicting settings of port"
self_url
<-
parseBaseUrl
$
"http://0.0.0.0:"
<>
show
port
param
<-
databaseParameters
file
conn
<-
connect
param
param
<-
databaseParameters
file
conn
<-
connect
param
repo_var
<-
readRepo
repo_saver
<-
mkRepoSaver
repo_var
scrapers_env
<-
newJobEnv
defaultSettings
manager
logger
<-
newStderrLoggerSet
defaultBufSize
pure
$
Env
{
_env_settings
=
settings
,
_env_logger
=
logger
,
_env_conn
=
conn
,
_env_manager
=
manager
,
_env_scrapers
=
scrapers_env
,
_env_self_url
=
self_url
{
_env_settings
=
settings
,
_env_logger
=
logger
,
_env_conn
=
conn
,
_env_repo_var
=
repo_var
,
_env_repo_saver
=
repo_saver
,
_env_manager
=
manager
,
_env_scrapers
=
scrapers_env
,
_env_self_url
=
self_url
}
data
DevEnv
=
DevEnv
{
_dev_env_conn
::
!
Connection
,
_dev_env_repo_var
::
!
(
MVar
NgramsRepo
)
,
_dev_env_repo_saver
::
!
(
IO
()
)
}
makeLenses
''
D
evEnv
instance
HasConnection
DevEnv
where
connection
=
dev_env_conn
instance
HasRepoVar
DevEnv
where
repoVar
=
dev_env_repo_var
instance
HasRepoSaver
DevEnv
where
repoSaver
=
dev_env_repo_saver
newDevEnvWith
::
FilePath
->
IO
DevEnv
newDevEnvWith
file
=
do
param
<-
databaseParameters
file
conn
<-
connect
param
repo_var
<-
newMVar
initMockRepo
repo_saver
<-
mkRepoSaver
repo_var
pure
$
DevEnv
{
_dev_env_conn
=
conn
,
_dev_env_repo_var
=
repo_var
,
_dev_env_repo_saver
=
repo_saver
}
newDevEnv
::
IO
DevEnv
newDevEnv
=
newDevEnvWith
"gargantext.ini"
-- Use only for dev
-- In particular this writes the repo file after running
-- the command.
-- This function is constrained to the DevEnv rather than
-- using HasConnection and HasRepoVar.
runCmdDev
::
Show
err
=>
DevEnv
->
Cmd'
DevEnv
err
a
->
IO
a
runCmdDev
env
f
=
(
either
(
fail
.
show
)
pure
=<<
runCmd
env
f
)
`
finally
`
runReaderT
saveRepo
env
-- Use only for dev
runCmdDevNoErr
::
DevEnv
->
Cmd'
DevEnv
()
a
->
IO
a
runCmdDevNoErr
=
runCmdDev
-- Use only for dev
runCmdDevServantErr
::
DevEnv
->
Cmd'
DevEnv
ServantErr
a
->
IO
a
runCmdDevServantErr
=
runCmdDev
src/Gargantext/Database/Cooc.hs
View file @
7da5cfa2
...
...
@@ -20,14 +20,15 @@ module Gargantext.Database.Cooc where
import
Database.PostgreSQL.Simple.SqlQQ
import
Gargantext.Prelude
import
Gargantext.Database.Utils
(
Cmd
,
runCmdDevNoErr
,
runPGSQuery
)
import
Gargantext.Database.Utils
(
Cmd
,
runPGSQuery
)
import
Gargantext.API.Settings
(
runCmdDevNoErr
,
DevEnv
)
type
CorpusId
=
Int
type
MainListId
=
Int
type
GroupListId
=
Int
coocTest
::
IO
[(
Int
,
Int
,
Int
)]
coocTest
=
runCmdDevNoErr
$
dBcooc
421968
446602
446599
coocTest
::
DevEnv
->
IO
[(
Int
,
Int
,
Int
)]
coocTest
env
=
runCmdDevNoErr
env
$
dBcooc
421968
446602
446599
dBcooc
::
CorpusId
->
MainListId
->
GroupListId
->
Cmd
err
[(
Int
,
Int
,
Int
)]
dBcooc
corpus
mainList
groupList
=
runPGSQuery
[
sql
|
...
...
src/Gargantext/Database/Flow.hs
View file @
7da5cfa2
This diff is collapsed.
Click to expand it.
src/Gargantext/Database/Lists.hs
0 → 100644
View file @
7da5cfa2
{-|
Module : Gargantext.Database.Lists
Description : Main requests of Node to the database
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module
Gargantext.Database.Lists
where
import
Control.Arrow
(
returnA
)
import
Gargantext.Core.Types
-- (NodePoly(..), NodeCorpus, ListId)
import
Gargantext.Core.Types.Individu
(
Username
)
import
Gargantext.Database.Config
(
nodeTypeId
)
import
Gargantext.Database.Schema.Node
-- (HasNodeError, queryNodeTable)
import
Gargantext.Database.Schema.User
-- (queryUserTable)
import
Gargantext.Database.Utils
import
Gargantext.Prelude
hiding
(
sum
,
head
)
import
Opaleye
hiding
(
FromField
)
import
Opaleye.Internal.QueryArr
(
Query
)
import
Prelude
hiding
(
null
,
id
,
map
,
sum
)
-- | To get all lists of a user
-- /!\ lists of different types of corpora (Annuaire or Documents)
listsWith
::
HasNodeError
err
=>
Username
->
Cmd
err
[
Maybe
ListId
]
listsWith
u
=
runOpaQuery
(
selectLists
u
)
where
selectLists
u
=
proc
()
->
do
(
auth_user
,
nodes
)
<-
listsWithJoin2
-<
()
restrict
-<
user_username
auth_user
.==
(
pgStrictText
u
)
restrict
-<
_node_typename
nodes
.==
(
toNullable
$
pgInt4
$
nodeTypeId
NodeList
)
returnA
-<
_node_id
nodes
listsWithJoin2
::
Query
(
UserRead
,
NodeReadNull
)
listsWithJoin2
=
leftJoin
queryUserTable
queryNodeTable
cond12
where
cond12
(
u
,
n
)
=
user_id
u
.==
_node_userId
n
{-
listsWithJoin3 :: Query (NodeRead, (UserRead, NodeReadNull))
listsWithJoin3 = leftJoin3 queryUserTable queryNodeTable queryNodeTable cond12 cond23
where
cond12 :: (NodeRead
cond12 (u,n) = user_id u .== _node_userId n
cond23 :: (NodeRead, (UserRead, NodeReadNull)) -> Column PGBool
cond23 (n1,(u,n2)) = (toNullable $ _node_id n1) .== _node_parentId n2
--}
src/Gargantext/Database/Metrics/TFICF.hs
View file @
7da5cfa2
...
...
@@ -143,4 +143,3 @@ GROUP BY nu.id,nu.terms
|]
src/Gargantext/Database/Schema/Ngrams.hs
View file @
7da5cfa2
...
...
@@ -25,8 +25,10 @@ Ngrams connection to the Database.
module
Gargantext.Database.Schema.Ngrams
where
import
Data.Aeson
(
FromJSON
,
FromJSONKey
)
import
Control.Lens
(
makeLenses
,
view
,
over
)
import
Control.Monad
(
mzero
)
import
Data.Aeson
import
Data.ByteString.Internal
(
ByteString
)
import
Data.Map
(
Map
,
fromList
,
lookup
,
fromListWith
)
import
Data.Profunctor.Product.TH
(
makeAdaptorAndInstance
)
...
...
@@ -58,13 +60,11 @@ type NgramsTerms = Text
type
NgramsId
=
Int
type
Size
=
Int
--{-
data
NgramsPoly
id
terms
n
=
NgramsDb
{
ngrams_id
::
id
,
ngrams_terms
::
terms
,
ngrams_n
::
n
}
deriving
(
Show
)
,
ngrams_terms
::
terms
,
ngrams_n
::
n
}
deriving
(
Show
)
--}
type
NgramsWrite
=
NgramsPoly
(
Maybe
(
Column
PGInt4
))
(
Column
PGText
)
(
Column
PGInt4
)
...
...
@@ -77,7 +77,6 @@ type NgramsReadNull = NgramsPoly (Column (Nullable PGInt4))
(
Column
(
Nullable
PGText
))
(
Column
(
Nullable
PGInt4
))
--{-
type
NgramsDb
=
NgramsPoly
Int
Text
Int
$
(
makeAdaptorAndInstance
"pNgramsDb"
''
N
gramsPoly
)
...
...
@@ -85,17 +84,16 @@ $(makeAdaptorAndInstance "pNgramsDb" ''NgramsPoly)
ngramsTable
::
Table
NgramsWrite
NgramsRead
ngramsTable
=
Table
"ngrams"
(
pNgramsDb
NgramsDb
{
ngrams_id
=
optional
"id"
,
ngrams_terms
=
required
"terms"
,
ngrams_n
=
required
"n"
}
)
--{-
,
ngrams_terms
=
required
"terms"
,
ngrams_n
=
required
"n"
}
)
queryNgramsTable
::
Query
NgramsRead
queryNgramsTable
=
queryTable
ngramsTable
dbGetNgramsDb
::
Cmd
err
[
NgramsDb
]
dbGetNgramsDb
=
runOpaQuery
queryNgramsTable
--}
-- | Main Ngrams Types
-- | Typed Ngrams
...
...
@@ -104,7 +102,12 @@ 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
)
deriving
(
Eq
,
Show
,
Ord
,
Enum
,
Bounded
,
Generic
)
instance
FromJSON
NgramsType
instance
FromJSONKey
NgramsType
instance
ToJSON
NgramsType
instance
ToJSONKey
NgramsType
newtype
NgramsTypeId
=
NgramsTypeId
Int
deriving
(
Eq
,
Show
,
Ord
,
Num
)
...
...
src/Gargantext/Database/Schema/Node.hs
View file @
7da5cfa2
...
...
@@ -155,32 +155,33 @@ instance QueryRunnerColumnDefault PGInt4 NodeId
------------------------------------------------------------------------
$
(
makeAdaptorAndInstance
"pNode"
''
N
odePoly
)
$
(
makeLensesWith
abbreviatedFields
''
N
odePoly
)
$
(
makeAdaptorAndInstance
"pNodeSearch"
''
N
odePolySearch
)
$
(
makeLensesWith
abbreviatedFields
''
N
odePolySearch
)
type
NodeWrite
=
NodePoly
(
Maybe
(
Column
PGInt4
)
)
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Maybe
(
Column
PGInt4
)
)
(
Column
PGText
)
(
Maybe
(
Column
PGTimestamptz
))
(
Column
PGJsonb
)
type
NodeRead
=
NodePoly
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
PGText
)
(
Column
PGTimestamptz
)
(
Column
PGJsonb
)
type
NodeReadNull
=
NodePoly
(
Column
(
Nullable
PGInt4
))
(
Column
(
Nullable
PGInt4
))
(
Column
(
Nullable
PGInt4
))
(
Column
(
Nullable
PGInt4
))
(
Column
(
Nullable
PGText
))
(
Column
(
Nullable
PGTimestamptz
))
(
Column
(
Nullable
PGJsonb
))
type
NodeWrite
=
NodePoly
(
Maybe
(
Column
PGInt4
)
)
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Maybe
(
Column
PGInt4
)
)
(
Column
PGText
)
(
Maybe
(
Column
PGTimestamptz
))
(
Column
PGJsonb
)
type
NodeRead
=
NodePoly
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
PGText
)
(
Column
PGTimestamptz
)
(
Column
PGJsonb
)
type
NodeReadNull
=
NodePoly
(
Column
(
Nullable
PGInt4
))
(
Column
(
Nullable
PGInt4
))
(
Column
(
Nullable
PGInt4
))
(
Column
(
Nullable
PGInt4
))
(
Column
(
Nullable
PGText
))
(
Column
(
Nullable
PGTimestamptz
))
(
Column
(
Nullable
PGJsonb
))
nodeTable
::
Table
NodeWrite
NodeRead
nodeTable
=
Table
"nodes"
(
pNode
Node
{
_node_id
=
optional
"id"
...
...
@@ -201,32 +202,38 @@ queryNodeTable = queryTable nodeTable
------------------------------------------------------------------------
-- | Node(Read|Write)Search is slower than Node(Write|Read) use it
-- for full text search only
type
NodeSearchWrite
=
NodePolySearch
(
Maybe
(
Column
PGInt4
))
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
(
Nullable
PGInt4
))
(
Column
(
PGText
))
(
Maybe
(
Column
PGTimestamptz
))
(
Column
PGJsonb
)
(
Maybe
(
Column
PGTSVector
))
type
NodeSearchRead
=
NodePolySearch
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
(
Nullable
PGInt4
))
(
Column
(
PGText
))
(
Column
PGTimestamptz
)
(
Column
PGJsonb
)
(
Column
PGTSVector
)
type
NodeSearchReadNull
=
NodePolySearch
(
Column
(
Nullable
PGInt4
))
(
Column
(
Nullable
PGInt4
))
(
Column
(
Nullable
PGInt4
))
(
Column
(
Nullable
PGInt4
))
(
Column
(
Nullable
PGText
))
(
Column
(
Nullable
PGTimestamptz
))
(
Column
(
Nullable
PGJsonb
))
(
Column
(
Nullable
PGTSVector
))
type
NodeSearchWrite
=
NodePolySearch
(
Maybe
(
Column
PGInt4
)
)
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
(
Nullable
PGInt4
)
)
(
Column
PGText
)
(
Maybe
(
Column
PGTimestamptz
))
(
Column
PGJsonb
)
(
Maybe
(
Column
PGTSVector
)
)
type
NodeSearchRead
=
NodePolySearch
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
PGInt4
)
(
Column
(
Nullable
PGInt4
))
(
Column
PGText
)
(
Column
PGTimestamptz
)
(
Column
PGJsonb
)
(
Column
PGTSVector
)
type
NodeSearchReadNull
=
NodePolySearch
(
Column
(
Nullable
PGInt4
)
)
(
Column
(
Nullable
PGInt4
)
)
(
Column
(
Nullable
PGInt4
)
)
(
Column
(
Nullable
PGInt4
)
)
(
Column
(
Nullable
PGText
)
)
(
Column
(
Nullable
PGTimestamptz
))
(
Column
(
Nullable
PGJsonb
)
)
(
Column
(
Nullable
PGTSVector
)
)
--{-
nodeTableSearch
::
Table
NodeSearchWrite
NodeSearchRead
...
...
@@ -336,7 +343,8 @@ type JSONB = QueryRunnerColumnDefault PGJsonb
getNode
::
JSONB
a
=>
NodeId
->
proxy
a
->
Cmd
err
(
Node
a
)
getNode
nId
_
=
do
fromMaybe
(
error
$
"Node does node exist: "
<>
show
nId
)
.
headMay
<$>
runOpaQuery
(
limit
1
$
selectNode
(
pgNodeId
nId
))
fromMaybe
(
error
$
"Node does node exist: "
<>
show
nId
)
.
headMay
<$>
runOpaQuery
(
limit
1
$
selectNode
(
pgNodeId
nId
))
getNodesWithType
::
Column
PGInt4
->
Cmd
err
[
Node
HyperdataDocument
]
getNodesWithType
=
runOpaQuery
.
selectNodesWithType
...
...
@@ -502,13 +510,16 @@ childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a c
type
Name
=
Text
-- | TODO mk all others nodes
mkNodeWithParent
::
HasNodeError
err
=>
NodeType
->
Maybe
ParentId
->
UserId
->
Name
->
Cmd
err
[
NodeId
]
mkNodeWithParent
NodeUser
(
Just
_
)
_
_
=
nodeError
UserNoParent
mkNodeWithParent
_
Nothing
_
_
=
nodeError
HasParent
mkNodeWithParent
nt
pId
uId
name
=
insertNodesWithParentR
pId
[
node
nt
name
hd
pId
uId
]
where
hd
=
HyperdataUser
.
Just
.
pack
$
show
EN
mkNodeWithParent
NodeUser
(
Just
_
)
_
_
=
nodeError
UserNoParent
mkNodeWithParent
NodeUser
Nothing
uId
name
=
insertNodesWithParentR
Nothing
[
node
NodeUser
name
hd
Nothing
uId
]
where
hd
=
HyperdataUser
.
Just
.
pack
$
show
EN
mkNodeWithParent
_
Nothing
_
_
=
nodeError
HasParent
mkNodeWithParent
_
_
_
_
=
nodeError
NotImplYet
mkRoot
::
HasNodeError
err
=>
Username
->
UserId
->
Cmd
err
[
RootId
]
mkRoot
uname
uId
=
case
uId
>
0
of
...
...
src/Gargantext/Database/Schema/schema.sql
View file @
7da5cfa2
CREATE
EXTENSION
IF
NOT
EXISTS
plpgsql
WITH
SCHEMA
pg_catalog
;
COMMENT
ON
EXTENSION
plpgsql
IS
'PL/pgSQL procedural language'
;
-- needed for rights management
-- CREATE EXTENSION IF NOT EXISTS acl WITH SCHEMA public;
-- CREATE USER WITH ...
-- createdb "gargandb"
...
...
@@ -23,6 +21,7 @@ CREATE TABLE public.auth_user (
ALTER
TABLE
public
.
auth_user
OWNER
TO
gargantua
;
-- TODO add publication_date
-- TODO typename -> type_id
CREATE
TABLE
public
.
nodes
(
...
...
@@ -40,7 +39,6 @@ CREATE TABLE public.nodes (
ALTER
TABLE
public
.
nodes
OWNER
TO
gargantua
;
CREATE
TABLE
public
.
ngrams
(
id
SERIAL
,
terms
character
varying
(
255
),
...
...
@@ -49,7 +47,9 @@ CREATE TABLE public.ngrams (
);
ALTER
TABLE
public
.
ngrams
OWNER
TO
gargantua
;
-- TODO: delete ID
--------------------------------------------------------------
--------------------------------------------------------------
-- TODO: delete delete this table
CREATE
TABLE
public
.
nodes_ngrams
(
id
SERIAL
,
node_id
integer
NOT
NULL
,
...
...
@@ -64,13 +64,21 @@ CREATE TABLE public.nodes_ngrams (
-- PRIMARY KEY (node_id,ngrams_id)
);
ALTER
TABLE
public
.
nodes_ngrams
OWNER
TO
gargantua
;
--------------------------------------------------------------
CREATE
TABLE
public
.
nodes_ngrams_repo
(
version
integer
NOT
NULL
,
patches
jsonb
DEFAULT
'{}'
::
jsonb
NOT
NULL
,
PRIMARY
KEY
(
version
)
);
ALTER
TABLE
public
.
nodes_ngrams_repo
OWNER
TO
gargantua
;
--------------------------------------------------------------
--
-- Name: nodes_ngrams_ngrams; Type: TABLE; Schema: public; Owner: gargantua
--
-- TODO: delete delete this table
CREATE
TABLE
public
.
nodes_ngrams_ngrams
(
node_id
integer
NOT
NULL
REFERENCES
public
.
nodes
(
id
)
ON
DELETE
CASCADE
,
node_id
integer
NOT
NULL
REFERENCES
public
.
nodes
(
id
)
ON
DELETE
CASCADE
,
ngram1_id
integer
NOT
NULL
REFERENCES
public
.
ngrams
(
id
)
ON
DELETE
CASCADE
,
ngram2_id
integer
NOT
NULL
REFERENCES
public
.
ngrams
(
id
)
ON
DELETE
CASCADE
,
weight
double
precision
,
...
...
@@ -79,7 +87,7 @@ CREATE TABLE public.nodes_ngrams_ngrams (
ALTER
TABLE
public
.
nodes_ngrams_ngrams
OWNER
TO
gargantua
;
---------------------------------------------------------
CREATE
TABLE
public
.
nodes_nodes
(
node1_id
integer
NOT
NULL
,
node2_id
integer
NOT
NULL
,
...
...
@@ -89,8 +97,23 @@ CREATE TABLE public.nodes_nodes (
PRIMARY
KEY
(
node1_id
,
node2_id
)
);
ALTER
TABLE
public
.
nodes_nodes
OWNER
TO
gargantua
;
---------------------------------------------------------
-- If needed for rights management at row level
-- CREATE EXTENSION IF NOT EXISTS acl WITH SCHEMA public;
CREATE
TABLE
public
.
rights
(
user_id
INTEGER
NOT
NULL
REFERENCES
public
.
auth_user
(
id
)
ON
DELETE
CASCADE
,
node_id
INTEGER
NOT
NULL
REFERENCES
public
.
nodes
(
id
)
ON
DELETE
CASCADE
,
rights
INTEGER
NOT
NULL
,
PRIMARY
KEY
(
user_id
,
node_id
)
);
ALTER
TABLE
public
.
rights
OWNER
TO
gargantua
;
CREATE
INDEX
rights_userId_nodeId
ON
public
.
rights
USING
btree
(
user_id
,
node_id
);
------------------------------------------------------------
-- INDEXES
CREATE
UNIQUE
INDEX
ON
public
.
auth_user
(
username
);
...
...
src/Gargantext/Database/Types/Node.hs
View file @
7da5cfa2
...
...
@@ -28,8 +28,7 @@ import Prelude (Enum, Bounded, minBound, maxBound)
import
GHC.Generics
(
Generic
)
import
Control.Lens
hiding
(
elements
)
import
qualified
Control.Lens
as
L
import
Control.Lens
hiding
(
elements
,
(
&
))
import
Control.Applicative
((
<*>
))
import
Control.Monad
(
mzero
)
...
...
@@ -41,7 +40,7 @@ import Data.ByteString.Lazy (ByteString)
import
Data.Either
import
Data.Eq
(
Eq
)
import
Data.Monoid
(
mempty
)
import
Data.Text
(
Text
,
unpack
)
import
Data.Text
(
Text
,
unpack
,
pack
)
import
Data.Time
(
UTCTime
)
import
Data.Time.Segment
(
jour
,
timesAfter
,
Granularity
(
D
))
import
Data.Swagger
...
...
@@ -61,7 +60,7 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
--import Gargantext.Database.Utils
------------------------------------------------------------------------
newtype
NodeId
=
NodeId
Int
deriving
(
Show
,
Read
,
Generic
,
Num
,
Eq
,
Ord
,
Enum
)
deriving
(
Show
,
Read
,
Generic
,
Num
,
Eq
,
Ord
,
Enum
,
ToJSONKey
,
FromJSONKey
,
ToJSON
,
FromJSON
)
instance
ToField
NodeId
where
toField
(
NodeId
n
)
=
toField
n
...
...
@@ -72,8 +71,6 @@ instance FromField NodeId where
if
(
n
::
Int
)
>
0
then
return
$
NodeId
n
else
mzero
instance
ToJSON
NodeId
instance
FromJSON
NodeId
instance
ToSchema
NodeId
instance
FromHttpApiData
NodeId
where
...
...
@@ -237,11 +234,8 @@ instance ToSchema Event where
declareNamedSchema
proxy
=
genericDeclareNamedSchema
defaultSchemaOptions
proxy
------------------------------------------------------------------------
type
Text'
=
Text
instance
Arbitrary
Text'
where
arbitrary
=
elements
[
"ici"
,
"la"
]
instance
Arbitrary
Text
where
arbitrary
=
elements
$
map
(
\
c
->
pack
[
c
])
[
'a'
..
'z'
]
data
Resource
=
Resource
{
resource_path
::
Maybe
Text
,
resource_scraper
::
Maybe
Text
...
...
@@ -324,6 +318,10 @@ data HyperdataList = HyperdataList { hyperdataList_preferences :: Maybe Text
$
(
deriveJSON
(
unPrefix
"hyperdataList_"
)
''
H
yperdataList
)
instance
Hyperdata
HyperdataList
instance
Arbitrary
HyperdataList
where
arbitrary
=
elements
[
HyperdataList
(
Just
"from list A"
)]
------------------------------------------------------------------------
data
HyperdataScore
=
HyperdataScore
{
hyperdataScore_preferences
::
Maybe
Text
}
deriving
(
Show
,
Generic
)
...
...
@@ -500,27 +498,24 @@ docExample = "{\"doi\":\"sdfds\",\"publication_day\":6,\"language_iso2\":\"en\",
instance
ToSchema
HyperdataCorpus
where
declareNamedSchema
proxy
=
genericDeclareNamedSchema
defaultSchemaOptions
proxy
L
.&
mapped
.
schema
.
description
?~
"a corpus"
L
.&
mapped
.
schema
.
example
?~
toJSON
hyperdataCorpus
&
mapped
.
schema
.
description
?~
"a corpus"
&
mapped
.
schema
.
example
?~
toJSON
hyperdataCorpus
instance
ToSchema
HyperdataAnnuaire
where
declareNamedSchema
proxy
=
genericDeclareNamedSchema
defaultSchemaOptions
proxy
L
.&
mapped
.
schema
.
description
?~
"an annuaire"
L
.&
mapped
.
schema
.
example
?~
toJSON
hyperdataAnnuaire
&
mapped
.
schema
.
description
?~
"an annuaire"
&
mapped
.
schema
.
example
?~
toJSON
hyperdataAnnuaire
instance
ToSchema
HyperdataDocument
where
declareNamedSchema
proxy
=
genericDeclareNamedSchema
defaultSchemaOptions
proxy
L
.&
mapped
.
schema
.
description
?~
"a document"
L
.&
mapped
.
schema
.
example
?~
toJSON
hyperdataDocument
&
mapped
.
schema
.
description
?~
"a document"
&
mapped
.
schema
.
example
?~
toJSON
hyperdataDocument
instance
ToSchema
HyperdataAny
where
declareNamedSchema
proxy
=
pure
$
genericNameSchema
defaultSchemaOptions
proxy
mempty
L
.
&
schema
.
description
?~
"a node"
L
.
&
schema
.
example
?~
emptyObject
-- TODO
&
schema
.
description
?~
"a node"
&
schema
.
example
?~
emptyObject
-- TODO
instance
ToSchema
hyperdata
=>
...
...
src/Gargantext/Database/Utils.hs
View file @
7da5cfa2
...
...
@@ -37,7 +37,6 @@ import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(Conversion
import
Database.PostgreSQL.Simple.Internal
(
Field
)
import
Gargantext.Prelude
import
Opaleye
(
Query
,
Unpackspec
,
showSqlForPostgres
,
FromFields
,
Select
,
runQuery
)
import
Servant
(
ServantErr
)
import
System.IO
(
FilePath
)
import
Text.Read
(
read
)
import
qualified
Data.ByteString
as
DB
...
...
@@ -49,13 +48,19 @@ class HasConnection env where
instance
HasConnection
Connection
where
connection
=
identity
type
CmdM
env
err
m
=
type
CmdM
'
env
err
m
=
(
MonadReader
env
m
,
HasConnection
env
,
MonadError
err
m
,
MonadIO
m
)
type
CmdM
env
err
m
=
(
CmdM'
env
err
m
,
HasConnection
env
)
type
Cmd'
env
err
a
=
forall
m
.
CmdM'
env
err
m
=>
m
a
type
Cmd
err
a
=
forall
m
env
.
CmdM
env
err
m
=>
m
a
-- TODO: ideally there should be very few calls to this functions.
...
...
@@ -64,22 +69,10 @@ mkCmd k = do
conn
<-
view
connection
liftIO
$
k
conn
runCmd
::
Connection
->
Cmd
err
a
->
IO
(
Either
err
a
)
runCmd
conn
m
=
runExceptT
$
runReaderT
m
conn
-- Use only for dev
runCmdDevWith
::
FilePath
->
Cmd
ServantErr
a
->
IO
a
runCmdDevWith
fp
f
=
do
conn
<-
connectGargandb
fp
either
(
fail
.
show
)
pure
=<<
runCmd
conn
f
-- Use only for dev
runCmdDev
::
Cmd
ServantErr
a
->
IO
a
runCmdDev
=
runCmdDevWith
"gargantext.ini"
-- Use only for dev
runCmdDevNoErr
::
Cmd
()
a
->
IO
a
runCmdDevNoErr
=
runCmdDevWith
"gargantext.ini"
runCmd
::
HasConnection
env
=>
env
->
Cmd'
env
err
a
->
IO
(
Either
err
a
)
runCmd
env
m
=
runExceptT
$
runReaderT
m
env
runOpaQuery
::
Default
FromFields
fields
haskells
=>
Select
fields
->
Cmd
err
[
haskells
]
runOpaQuery
q
=
mkCmd
$
\
c
->
runQuery
c
q
...
...
src/Gargantext/Text/Flow.hs
View file @
7da5cfa2
...
...
@@ -43,6 +43,7 @@ import Gargantext.Text.Terms (TermType, extractTerms)
import
Gargantext.Viz.Graph
(
Graph
(
..
),
data2graph
)
import
Gargantext.Viz.Graph.Bridgeness
(
bridgeness
)
import
Gargantext.Viz.Graph.Distances.Matrice
(
measureConditional
)
--import Gargantext.Viz.Graph.Distances.Matrice (distributional)
import
Gargantext.Viz.Graph.Index
(
createIndices
,
toIndex
,
map2mat
,
mat2map
)
{-
____ _ _
...
...
@@ -153,7 +154,7 @@ cooc2graph myCooc = do
-- let distance = fromIndex fi distanceMap
--printDebug "distance" $ M.size distance
partitions
<-
case
M
.
size
distanceMap
>
0
of
True
->
cLouvain
distanceMap
False
->
panic
"Text.Flow: DistanceMap is empty"
...
...
src/Gargantext/Text/Metrics.hs
View file @
7da5cfa2
...
...
@@ -63,7 +63,7 @@ filterCooc' (FilterConfig _ _ _ _ (DefaultValue dv)) ts m = trace ("coocScored "
where
selection
=
[(
x
,
y
)
|
x
<-
ts
,
y
<-
ts
-- , x >=
y
,
x
>
y
]
...
...
src/Gargantext/Viz/Phylo.hs
View file @
7da5cfa2
...
...
@@ -7,7 +7,7 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Specifications of Phylomemy format.
Specifications of Phylomemy
export
format.
Phylomemy can be described as a Temporal Graph with different scale of
granularity of group of ngrams (terms and multi-terms).
...
...
@@ -39,9 +39,9 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
import
Gargantext.Prelude
------------------------------------------------------------------------
data
Phylo
Forma
t
=
Phylo
Format
{
_phyloForma
t_param
::
PhyloParam
,
_phylo
Forma
t_data
::
Phylo
data
Phylo
Expor
t
=
Phylo
Export
{
_phyloExpor
t_param
::
PhyloParam
,
_phylo
Expor
t_data
::
Phylo
}
deriving
(
Generic
)
-- | .phylo parameters
...
...
@@ -66,7 +66,7 @@ data Software =
-- Ngrams : list of all (possible) terms contained in the phylomemy (with their id)
-- Steps : list of all steps to build the phylomemy
data
Phylo
=
Phylo
{
_phylo_
p
uration
::
(
Start
,
End
)
Phylo
{
_phylo_
d
uration
::
(
Start
,
End
)
,
_phylo_ngrams
::
[
Ngram
]
,
_phylo_periods
::
[
PhyloPeriod
]
}
...
...
@@ -109,27 +109,28 @@ type PhyloLevelId = (PhyloPeriodId, Int)
-- Ngrams: set of terms that build the group
-- Period Parents|Childs: weighted link to Parents|Childs (Temporal Period axis)
-- Level Parents|Childs: weighted link to Parents|Childs (Level Granularity axis)
-- Pointers are directed link from Self to any PhyloGroup (/= Self ?)
data
PhyloGroup
=
PhyloGroup
{
_phylo_groupId
::
PhyloGroupId
,
_phylo_groupLabel
::
Maybe
Text
,
_phylo_groupNgrams
::
[
NgramsId
]
,
_phylo_groupPeriodParents
::
[
Edge
]
,
_phylo_groupPeriodChilds
::
[
Edge
]
,
_phylo_groupPeriodParents
::
[
Pointer
]
,
_phylo_groupPeriodChilds
::
[
Pointer
]
,
_phylo_groupLevelParents
::
[
Edge
]
,
_phylo_groupLevelChilds
::
[
Edge
]
,
_phylo_groupLevelParents
::
[
Pointer
]
,
_phylo_groupLevelChilds
::
[
Pointer
]
}
deriving
(
Generic
)
type
PhyloGroupId
=
(
PhyloLevelId
,
Int
)
type
Edge
=
(
PhyloGroupId
,
Weight
)
type
Pointer
=
(
PhyloGroupId
,
Weight
)
type
Weight
=
Double
-- | Lenses
makeLenses
''
P
hylo
makeLenses
''
P
hyloParam
makeLenses
''
P
hylo
Forma
t
makeLenses
''
P
hylo
Expor
t
makeLenses
''
S
oftware
-- | JSON instances
...
...
@@ -138,9 +139,9 @@ $(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
$
(
deriveJSON
(
unPrefix
"_phylo_level"
)
''
P
hyloLevel
)
$
(
deriveJSON
(
unPrefix
"_phylo_group"
)
''
P
hyloGroup
)
--
$
(
deriveJSON
(
unPrefix
"_software_"
)
''
S
oftware
)
$
(
deriveJSON
(
unPrefix
"_software_"
)
''
S
oftware
)
$
(
deriveJSON
(
unPrefix
"_phyloParam_"
)
''
P
hyloParam
)
$
(
deriveJSON
(
unPrefix
"_phylo
Format_"
)
''
P
hyloFormat
)
$
(
deriveJSON
(
unPrefix
"_phylo
Export_"
)
''
P
hyloExport
)
-- | TODO XML instances
src/Gargantext/Viz/Phylo/Tools.hs
0 → 100644
View file @
7da5cfa2
{-|
Module : Gargantext.Viz.Phylo.Tools
Description : Phylomemy tools
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Phylo Toolbox:
- functions to build a Phylo
- functions to filter the cliques
- functions to manage a Phylo
Group Functions (TODO list)
- cohesion sur un groupe
- distance au dernier branchement
- âge du groupe
Futre Idea: temporal zoom on Phylo
phyloZoomOut :: (PeriodGrain, Phylo) -> [(PeriodGrain, Phylo)]
(from smallest granularity, it increases (zoom out) the periods of the Phylo)
Moral idea: viz from out to in
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module
Gargantext.Viz.Phylo.Tools
where
import
Data.Set
(
Set
)
import
Data.Map
(
Map
)
import
Data.Map
as
Map
hiding
(
Map
)
import
Gargantext.Prelude
import
Gargantext.Viz.Phylo
import
Gargantext.Viz.Phylo.Example
-- | Some types to help reading
type
Clique
=
Set
Ngrams
type
Support
=
Int
type
MinSize
=
Int
-- | Building a phylo
-- (Indicative and schematic function)
buildPhylo
::
Support
->
MinSize
->
Map
Clique
Support
->
Phylo
buildPhylo
s
m
mcs
=
level2Phylo
.
groups2level
.
clusters2group
.
map
clique2cluster
.
filterCliques
s
m
level2Phylo
::
PhyloLevel
->
Phylo
->
Phylo
level2Phylo
=
undefined
groups2level
::
[
PhyloGroup
]
->
PhyloLevel
groups2level
=
undefined
clusters2group
::
[
Cluster
Ngrams
]
->
PhyloGroup
clusters2group
=
undefined
clique2cluster
::
Clique
->
Cluster
Ngrams
clique2cluster
=
undefined
-- | Filtering the cliques before bulding the Phylo
-- (Support and MinSize as parameter of the finale function to build a phylo)
-- idea: log of Corpus size (of docs)
filterCliques
::
Support
->
MinSize
->
Map
Clique
Support
->
[
Clique
]
filterCliques
s
ms
=
maximalCliques
.
filterWithSizeSet
ms
.
Map
.
keys
.
filterWithSupport
s
-- | Hapaxify / Threshold
-- hapax s = 1
-- ?
filterWithSupport
::
Support
->
Map
Clique
Support
->
Map
Clique
Support
filterWithSupport
s
=
Map
.
filter
(
>
s
)
filterWithSizeSet
::
MinSize
->
[
Clique
]
->
[
Clique
]
filterWithSizeSet
=
undefined
-- | filtre les cliques de ngrams compris dans une clique plus grande
-- /!\ optim inside
maximalCliques
::
[
Clique
]
->
[
Clique
]
maximalCliques
=
undefined
-- | Phylo management
-- | PhyloLevel Management
viewGroups
::
(
Start
,
End
)
->
PhyloLevel
->
Phylo
->
[
PhyloGroup
]
viewGroups
=
undefined
viewLevels
::
(
Start
,
End
)
->
Phylo
->
[
PhyloLevel
]
viewLevels
=
undefined
-- | tous les terme des champs, tous les parents et les enfants
setGroup
::
PhyloGroup
->
PhyloGroup
->
PhyloGroup
setGroup
=
undefined
--removeTerms :: recalculer les cliques pour ces termes
--addTerms
stack.yaml
View file @
7da5cfa2
...
...
@@ -12,6 +12,8 @@ packages:
allow-newer
:
true
extra-deps
:
-
json-state-0.1.0.1
-
time-units-1.0.0
-
git
:
https://github.com/delanoe/data-time-segment.git
commit
:
4e3d57d80e9dfe6624c8eeaa8595fc8fe64d8723
-
git
:
https://gitlab.iscpif.fr/gargantext/hlcm.git
...
...
@@ -34,4 +36,4 @@ extra-deps:
-
servant-flatten-0.2
-
servant-multipart-0.11.2
-
stemmer-0.5.2
-
validity-0.
8
.0.0
# patches-{map,class}
-
validity-0.
9
.0.0
# patches-{map,class}
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment