Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
H
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
Przemyslaw Kaminski
haskell-gargantext
Commits
49436f17
Commit
49436f17
authored
Nov 12, 2021
by
Przemyslaw Kaminski
Browse files
Options
Browse Files
Download
Plain Diff
Merge branch 'dev' into 86-dev-graphql
parents
133d581e
02a4c6df
Changes
30
Hide whitespace changes
Inline
Side-by-side
Showing
30 changed files
with
234 additions
and
210 deletions
+234
-210
Main.hs
bin/gargantext-import/Main.hs
+3
-3
removeUnusedDocuments.sql
devops/postgres/tools/removeUnusedDocuments.sql
+14
-0
removeUnusedNgrams.sql
devops/postgres/tools/removeUnusedNgrams.sql
+21
-0
gargantext.ini_toModify
gargantext.ini_toModify
+8
-0
package.yaml
package.yaml
+31
-30
Auth.hs
src/Gargantext/API/Admin/Auth.hs
+8
-6
EnvTypes.hs
src/Gargantext/API/Admin/EnvTypes.hs
+9
-22
Settings.hs
src/Gargantext/API/Admin/Settings.hs
+13
-11
Dev.hs
src/Gargantext/API/Dev.hs
+4
-3
Ngrams.hs
src/Gargantext/API/Ngrams.hs
+8
-12
Tools.hs
src/Gargantext/API/Ngrams/Tools.hs
+2
-2
Types.hs
src/Gargantext/API/Ngrams/Types.hs
+2
-44
Contact.hs
src/Gargantext/API/Node/Contact.hs
+1
-1
New.hs
src/Gargantext/API/Node/Corpus/New.hs
+4
-3
File.hs
src/Gargantext/API/Node/Corpus/New/File.hs
+1
-0
DocumentUpload.hs
src/Gargantext/API/Node/DocumentUpload.hs
+1
-1
DocumentsFromWriteNodes.hs
src/Gargantext/API/Node/DocumentsFromWriteNodes.hs
+1
-1
Prelude.hs
src/Gargantext/API/Prelude.hs
+3
-1
Mail.hs
src/Gargantext/Core/Mail.hs
+7
-7
Types.hs
src/Gargantext/Core/Mail/Types.hs
+18
-0
NodeStory.hs
src/Gargantext/Core/NodeStory.hs
+2
-3
Delete.hs
src/Gargantext/Database/Action/Delete.hs
+5
-4
Flow.hs
src/Gargantext/Database/Action/Flow.hs
+22
-8
Mail.hs
src/Gargantext/Database/Action/Mail.hs
+8
-8
Metrics.hs
src/Gargantext/Database/Action/Metrics.hs
+2
-1
New.hs
src/Gargantext/Database/Action/User/New.hs
+14
-13
Prelude.hs
src/Gargantext/Database/Prelude.hs
+15
-18
NodesNgramsRepo.hs
src/Gargantext/Database/Query/Table/NodesNgramsRepo.hs
+2
-3
NodesNgramsRepo.hs
src/Gargantext/Database/Schema/NodesNgramsRepo.hs
+3
-2
stack.yaml
stack.yaml
+2
-3
No files found.
bin/gargantext-import/Main.hs
View file @
49436f17
...
@@ -47,13 +47,13 @@ main = do
...
@@ -47,13 +47,13 @@ main = do
tt
=
(
Multi
EN
)
tt
=
(
Multi
EN
)
format
=
CsvGargV3
-- CsvHal --WOS
format
=
CsvGargV3
-- CsvHal --WOS
corpus
::
forall
m
.
FlowCmdM
DevEnv
GargError
m
=>
m
CorpusId
corpus
::
forall
m
.
FlowCmdM
DevEnv
GargError
m
=>
m
CorpusId
corpus
=
flowCorpusFile
(
UserName
$
cs
user
)
(
Left
(
cs
name
::
Text
))
(
read
limit
::
Int
)
tt
format
corpusPath
Nothing
corpus
=
flowCorpusFile
(
UserName
$
cs
user
)
(
Left
(
cs
name
::
Text
))
(
read
limit
::
Int
)
tt
format
corpusPath
Nothing
(
\
_
->
pure
()
)
corpusCsvHal
::
forall
m
.
FlowCmdM
DevEnv
GargError
m
=>
m
CorpusId
corpusCsvHal
::
forall
m
.
FlowCmdM
DevEnv
GargError
m
=>
m
CorpusId
corpusCsvHal
=
flowCorpusFile
(
UserName
$
cs
user
)
(
Left
(
cs
name
::
Text
))
(
read
limit
::
Int
)
tt
CsvHal
corpusPath
Nothing
corpusCsvHal
=
flowCorpusFile
(
UserName
$
cs
user
)
(
Left
(
cs
name
::
Text
))
(
read
limit
::
Int
)
tt
CsvHal
corpusPath
Nothing
(
\
_
->
pure
()
)
annuaire
::
forall
m
.
FlowCmdM
DevEnv
GargError
m
=>
m
CorpusId
annuaire
::
forall
m
.
FlowCmdM
DevEnv
GargError
m
=>
m
CorpusId
annuaire
=
flowAnnuaire
(
UserName
$
cs
user
)
(
Left
"Annuaire"
)
(
Multi
EN
)
corpusPath
annuaire
=
flowAnnuaire
(
UserName
$
cs
user
)
(
Left
"Annuaire"
)
(
Multi
EN
)
corpusPath
(
\
_
->
pure
()
)
{-
{-
let debatCorpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
let debatCorpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
...
...
devops/postgres/tools/removeUnusedDocuments.sql
0 → 100644
View file @
49436f17
WITH
repeated
AS
(
select
nn
.
node2_id
AS
id
,
count
(
*
)
AS
c
FROM
nodes_nodes
nn
GROUP
BY
nn
.
node2_id
)
DELETE
FROM
nodes
n
USING
repeated
r
WHERE
n
.
id
=
r
.
id
AND
r
.
c
<=
1
;
devops/postgres/tools/removeUnusedNgrams.sql
0 → 100644
View file @
49436f17
WITH
listed
AS
(
select
nn
.
ngrams_id
AS
id
,
count
(
*
)
AS
c
FROM
node_node_ngrams
nn
GROUP
BY
nn
.
ngrams_id
)
--SELECT count(*) from listed l
-- WHERE
--l.c <= 1
DELETE
FROM
ngrams
n
USING
listed
l
WHERE
n
.
id
=
l
.
id
AND
l
.
c
<=
1
;
gargantext.ini_toModify
View file @
49436f17
...
@@ -67,3 +67,11 @@ DB_PASS = PASSWORD_TO_CHANGE
...
@@ -67,3 +67,11 @@ DB_PASS = PASSWORD_TO_CHANGE
LOG_FILE = /var/log/gargantext/backend.log
LOG_FILE = /var/log/gargantext/backend.log
LOG_LEVEL = LevelDebug
LOG_LEVEL = LevelDebug
LOG_FORMATTER = verbose
LOG_FORMATTER = verbose
[mail]
MAIL_PORT = 25
MAIL_HOST = localhost
MAIL_USER = gargantext
MAIL_PASSWORD =
# Normal | SSL | TLS | STARTTLS
MAIL_LOGIN_TYPE = Normal
package.yaml
View file @
49436f17
name
:
gargantext
name
:
gargantext
version
:
'
0.0.4.
6
'
version
:
'
0.0.4.
7.1
'
synopsis
:
Search, map, share
synopsis
:
Search, map, share
description
:
Please see README.md
description
:
Please see README.md
category
:
Data
category
:
Data
...
@@ -371,19 +371,19 @@ executables:
...
@@ -371,19 +371,19 @@ executables:
-
gargantext-prelude
-
gargantext-prelude
-
base
-
base
gargantext-upgrade
:
#
gargantext-upgrade:
main
:
Main.hs
#
main: Main.hs
source-dirs
:
bin/gargantext-upgrade
#
source-dirs: bin/gargantext-upgrade
ghc-options
:
#
ghc-options:
-
-threaded
#
- -threaded
-
-rtsopts
#
- -rtsopts
-
-with-rtsopts=-N
#
- -with-rtsopts=-N
-
-O2
#
- -O2
-
-Wmissing-signatures
#
- -Wmissing-signatures
dependencies
:
#
dependencies:
-
gargantext
#
- gargantext
-
gargantext-prelude
#
- gargantext-prelude
-
base
#
- base
gargantext-admin
:
gargantext-admin
:
main
:
Main.hs
main
:
Main.hs
...
@@ -399,22 +399,23 @@ executables:
...
@@ -399,22 +399,23 @@ executables:
-
gargantext-prelude
-
gargantext-prelude
-
base
-
base
gargantext-cbor2json
:
main
:
Main.hs
# gargantext-cbor2json:
source-dirs
:
bin/gargantext-cbor2json
# main: Main.hs
ghc-options
:
# source-dirs: bin/gargantext-cbor2json
-
-threaded
# ghc-options:
-
-rtsopts
# - -threaded
-
-with-rtsopts=-N
# - -rtsopts
-
-O2
# - -with-rtsopts=-N
-
-Wmissing-signatures
# - -O2
dependencies
:
# - -Wmissing-signatures
-
gargantext
# dependencies:
-
gargantext-prelude
# - gargantext
-
base
# - gargantext-prelude
-
bytestring
# - base
-
aeson
# - bytestring
-
serialise
# - aeson
# - serialise
tests
:
tests
:
...
...
src/Gargantext/API/Admin/Auth.hs
View file @
49436f17
...
@@ -20,6 +20,7 @@ TODO-ACCESS Critical
...
@@ -20,6 +20,7 @@ TODO-ACCESS Critical
-}
-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ScopedTypeVariables #-}
module
Gargantext.API.Admin.Auth
module
Gargantext.API.Admin.Auth
...
@@ -35,17 +36,18 @@ import Servant
...
@@ -35,17 +36,18 @@ import Servant
import
Servant.Auth.Server
import
Servant.Auth.Server
import
qualified
Gargantext.Prelude.Crypto.Auth
as
Auth
import
qualified
Gargantext.Prelude.Crypto.Auth
as
Auth
import
Gargantext.API.Admin.Types
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Prelude
(
HasJoseError
(
..
),
joseError
,
HasServerError
,
GargServerC
)
import
Gargantext.API.Prelude
(
HasJoseError
(
..
),
joseError
,
HasServerError
,
GargServerC
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Types.Individu
(
User
(
..
),
Username
,
GargPassword
(
..
))
import
Gargantext.Core.Types.Individu
(
User
(
..
),
Username
,
GargPassword
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
),
UserId
)
import
Gargantext.Database.Prelude
(
Cmd
'
,
CmdM
,
HasConnectionPool
,
HasConfig
)
import
Gargantext.Database.Query.Table.User
import
Gargantext.Database.Query.Tree
(
isDescendantOf
,
isIn
)
import
Gargantext.Database.Query.Tree
(
isDescendantOf
,
isIn
)
import
Gargantext.Database.Query.Tree.Root
(
getRoot
)
import
Gargantext.Database.Query.Tree.Root
(
getRoot
)
import
Gargantext.Database.Schema.Node
(
NodePoly
(
_node_id
))
import
Gargantext.Database.Schema.Node
(
NodePoly
(
_node_id
))
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
),
UserId
)
import
Gargantext.Database.Prelude
(
Cmd
'
,
CmdM
,
HasConnectionPool
,
HasConfig
)
import
Gargantext.Prelude
hiding
(
reverse
)
import
Gargantext.Prelude
hiding
(
reverse
)
import
Gargantext.Database.Query.Table.User
---------------------------------------------------
---------------------------------------------------
...
@@ -60,7 +62,7 @@ makeTokenForUser uid = do
...
@@ -60,7 +62,7 @@ makeTokenForUser uid = do
either
joseError
(
pure
.
toStrict
.
decodeUtf8
)
e
either
joseError
(
pure
.
toStrict
.
decodeUtf8
)
e
-- TODO not sure about the encoding...
-- TODO not sure about the encoding...
checkAuthRequest
::
(
HasSettings
env
,
HasConnectionPool
env
,
HasJoseError
err
,
HasConfig
env
)
checkAuthRequest
::
(
HasSettings
env
,
HasConnectionPool
env
,
HasJoseError
err
,
HasConfig
env
,
HasMail
env
)
=>
Username
=>
Username
->
GargPassword
->
GargPassword
->
Cmd'
env
err
CheckAuth
->
Cmd'
env
err
CheckAuth
...
@@ -79,7 +81,7 @@ checkAuthRequest u (GargPassword p) = do
...
@@ -79,7 +81,7 @@ checkAuthRequest u (GargPassword p) = do
token
<-
makeTokenForUser
uid
token
<-
makeTokenForUser
uid
pure
$
Valid
token
uid
pure
$
Valid
token
uid
auth
::
(
HasSettings
env
,
HasConnectionPool
env
,
HasJoseError
err
,
HasConfig
env
)
auth
::
(
HasSettings
env
,
HasConnectionPool
env
,
HasJoseError
err
,
HasConfig
env
,
HasMail
env
)
=>
AuthRequest
->
Cmd'
env
err
AuthResponse
=>
AuthRequest
->
Cmd'
env
err
AuthResponse
auth
(
AuthRequest
u
p
)
=
do
auth
(
AuthRequest
u
p
)
=
do
checkAuthRequest'
<-
checkAuthRequest
u
p
checkAuthRequest'
<-
checkAuthRequest
u
p
...
...
src/Gargantext/API/Admin/EnvTypes.hs
View file @
49436f17
...
@@ -14,24 +14,25 @@ import Servant.Job.Async (HasJobEnv(..), Job)
...
@@ -14,24 +14,25 @@ import Servant.Job.Async (HasJobEnv(..), Job)
import
System.Log.FastLogger
import
System.Log.FastLogger
import
qualified
Servant.Job.Core
import
qualified
Servant.Job.Core
import
Gargantext.API.Ngrams.Types
(
HasRepoVar
(
..
),
HasRepoSaver
(
..
),
HasRepo
(
..
),
RepoEnv
(
..
))
import
Gargantext.API.Admin.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
),
HasConfig
(
..
))
import
Gargantext.Database.Prelude
(
HasConnectionPool
(
..
),
HasConfig
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
GargConfig
(
..
))
import
Gargantext.Prelude.Config
(
GargConfig
(
..
))
import
Gargantext.
Core.NodeStory
import
Gargantext.
Prelude.Mail.Types
(
MailConfig
)
data
Env
=
Env
data
Env
=
Env
{
_env_settings
::
!
Settings
{
_env_settings
::
!
Settings
,
_env_logger
::
!
LoggerSet
,
_env_logger
::
!
LoggerSet
,
_env_pool
::
!
(
Pool
Connection
)
,
_env_pool
::
!
(
Pool
Connection
)
,
_env_repo
::
!
RepoEnv
,
_env_nodeStory
::
!
NodeStoryEnv
,
_env_nodeStory
::
!
NodeStoryEnv
,
_env_manager
::
!
Manager
,
_env_manager
::
!
Manager
,
_env_self_url
::
!
BaseUrl
,
_env_self_url
::
!
BaseUrl
,
_env_scrapers
::
!
ScrapersEnv
,
_env_scrapers
::
!
ScrapersEnv
,
_env_config
::
!
GargConfig
,
_env_config
::
!
GargConfig
,
_env_mail
::
!
MailConfig
}
}
deriving
(
Generic
)
deriving
(
Generic
)
...
@@ -55,15 +56,8 @@ instance HasNodeStorySaver Env where
...
@@ -55,15 +56,8 @@ instance HasNodeStorySaver Env where
instance
HasSettings
Env
where
instance
HasSettings
Env
where
settings
=
env_settings
settings
=
env_settings
-- Specific to Repo
instance
HasMail
Env
where
instance
HasRepoVar
Env
where
mailSettings
=
env_mail
repoVar
=
repoEnv
.
repoVar
instance
HasRepoSaver
Env
where
repoSaver
=
repoEnv
.
repoSaver
instance
HasRepo
Env
where
repoEnv
=
env_repo
instance
Servant
.
Job
.
Core
.
HasEnv
Env
(
Job
JobLog
JobLog
)
where
instance
Servant
.
Job
.
Core
.
HasEnv
Env
(
Job
JobLog
JobLog
)
where
...
@@ -83,10 +77,10 @@ makeLenses ''MockEnv
...
@@ -83,10 +77,10 @@ makeLenses ''MockEnv
data
DevEnv
=
DevEnv
data
DevEnv
=
DevEnv
{
_dev_env_settings
::
!
Settings
{
_dev_env_settings
::
!
Settings
,
_dev_env_repo
::
!
RepoEnv
,
_dev_env_config
::
!
GargConfig
,
_dev_env_config
::
!
GargConfig
,
_dev_env_pool
::
!
(
Pool
Connection
)
,
_dev_env_pool
::
!
(
Pool
Connection
)
,
_dev_env_nodeStory
::
!
NodeStoryEnv
,
_dev_env_nodeStory
::
!
NodeStoryEnv
,
_dev_env_mail
::
!
MailConfig
}
}
makeLenses
''
D
evEnv
makeLenses
''
D
evEnv
...
@@ -110,12 +104,5 @@ instance HasNodeStoryVar DevEnv where
...
@@ -110,12 +104,5 @@ instance HasNodeStoryVar DevEnv where
instance
HasNodeStorySaver
DevEnv
where
instance
HasNodeStorySaver
DevEnv
where
hasNodeStorySaver
=
hasNodeStory
.
nse_saver
hasNodeStorySaver
=
hasNodeStory
.
nse_saver
instance
HasMail
DevEnv
where
instance
HasRepoVar
DevEnv
where
mailSettings
=
dev_env_mail
repoVar
=
repoEnv
.
repoVar
instance
HasRepoSaver
DevEnv
where
repoSaver
=
repoEnv
.
repoSaver
instance
HasRepo
DevEnv
where
repoEnv
=
dev_env_repo
src/Gargantext/API/Admin/Settings.hs
View file @
49436f17
...
@@ -18,9 +18,8 @@ TODO-SECURITY: Critical
...
@@ -18,9 +18,8 @@ TODO-SECURITY: Critical
module
Gargantext.API.Admin.Settings
module
Gargantext.API.Admin.Settings
where
where
import
Codec.Serialise
(
Serialise
(),
serialise
,
deserialise
)
-- import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import
Control.Concurrent
import
Codec.Serialise
(
Serialise
(),
serialise
)
import
Control.Debounce
(
mkDebounce
,
defaultDebounceSettings
,
debounceFreq
,
debounceAction
)
import
Control.Lens
import
Control.Lens
import
Control.Monad.Logger
import
Control.Monad.Logger
import
Control.Monad.Reader
import
Control.Monad.Reader
...
@@ -34,7 +33,7 @@ import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSe
...
@@ -34,7 +33,7 @@ import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSe
import
Servant.Client
(
parseBaseUrl
)
import
Servant.Client
(
parseBaseUrl
)
import
Servant.Job.Async
(
newJobEnv
,
defaultSettings
)
import
Servant.Job.Async
(
newJobEnv
,
defaultSettings
)
import
System.Directory
import
System.Directory
import
System.FileLock
(
tryLockFile
,
unlockFile
,
SharedExclusive
(
Exclusive
))
--
import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
import
System.IO
(
FilePath
,
hClose
)
import
System.IO
(
FilePath
,
hClose
)
import
System.IO.Temp
(
withTempFile
)
import
System.IO.Temp
(
withTempFile
)
import
System.Log.FastLogger
import
System.Log.FastLogger
...
@@ -43,10 +42,11 @@ import qualified Data.ByteString.Lazy as L
...
@@ -43,10 +42,11 @@ import qualified Data.ByteString.Lazy as L
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.EnvTypes
import
Gargantext.API.Admin.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Ngrams.Types
(
NgramsRepo
,
HasRepo
(
..
),
RepoEnv
(
..
),
r_version
,
initRepo
,
renv_var
,
renv_lock
)
--
import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
import
Gargantext.Database.Prelude
(
databaseParameters
,
HasConfig
(
..
)
)
import
Gargantext.Database.Prelude
(
databaseParameters
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
gc_repofilepath
)
-- import Gargantext.Prelude.Config (gc_repofilepath)
import
qualified
Gargantext.Prelude.Mail
as
Mail
devSettings
::
FilePath
->
IO
Settings
devSettings
::
FilePath
->
IO
Settings
devSettings
jwkFile
=
do
devSettings
jwkFile
=
do
...
@@ -113,7 +113,7 @@ repoSaverAction repoDir a = do
...
@@ -113,7 +113,7 @@ repoSaverAction repoDir a = do
--
{-
{-
-- The use of mkDebounce makes sure that repoSaverAction is not called too often.
-- The use of mkDebounce makes sure that repoSaverAction is not called too often.
-- If repoSaverAction start taking more time than the debounceFreq then it should
-- If repoSaverAction start taking more time than the debounceFreq then it should
-- be increased.
-- be increased.
...
@@ -133,6 +133,8 @@ mkRepoSaver repoDir repo_var = mkDebounce settings'
...
@@ -133,6 +133,8 @@ mkRepoSaver repoDir repo_var = mkDebounce settings'
-- Add a new MVar just for saving.
-- Add a new MVar just for saving.
}
}
-}
{-
readRepoEnv :: FilePath -> IO RepoEnv
readRepoEnv :: FilePath -> IO RepoEnv
readRepoEnv repoDir = do
readRepoEnv repoDir = do
-- Does file exist ? :: Bool
-- Does file exist ? :: Bool
...
@@ -178,27 +180,27 @@ newEnv port file = do
...
@@ -178,27 +180,27 @@ newEnv port file = do
self_url_env
<-
parseBaseUrl
$
"http://0.0.0.0:"
<>
show
port
self_url_env
<-
parseBaseUrl
$
"http://0.0.0.0:"
<>
show
port
dbParam
<-
databaseParameters
file
dbParam
<-
databaseParameters
file
pool
<-
newPool
dbParam
pool
<-
newPool
dbParam
repo
<-
readRepoEnv
(
_gc_repofilepath
config_env
)
nodeStory_env
<-
readNodeStoryEnv
(
_gc_repofilepath
config_env
)
nodeStory_env
<-
readNodeStoryEnv
(
_gc_repofilepath
config_env
)
scrapers_env
<-
newJobEnv
defaultSettings
manager_env
scrapers_env
<-
newJobEnv
defaultSettings
manager_env
logger
<-
newStderrLoggerSet
defaultBufSize
logger
<-
newStderrLoggerSet
defaultBufSize
config_mail
<-
Mail
.
readConfig
file
pure
$
Env
pure
$
Env
{
_env_settings
=
settings'
{
_env_settings
=
settings'
,
_env_logger
=
logger
,
_env_logger
=
logger
,
_env_pool
=
pool
,
_env_pool
=
pool
,
_env_repo
=
repo
,
_env_nodeStory
=
nodeStory_env
,
_env_nodeStory
=
nodeStory_env
,
_env_manager
=
manager_env
,
_env_manager
=
manager_env
,
_env_scrapers
=
scrapers_env
,
_env_scrapers
=
scrapers_env
,
_env_self_url
=
self_url_env
,
_env_self_url
=
self_url_env
,
_env_config
=
config_env
,
_env_config
=
config_env
,
_env_mail
=
config_mail
}
}
newPool
::
ConnectInfo
->
IO
(
Pool
Connection
)
newPool
::
ConnectInfo
->
IO
(
Pool
Connection
)
newPool
param
=
createPool
(
connect
param
)
close
1
(
60
*
60
)
8
newPool
param
=
createPool
(
connect
param
)
close
1
(
60
*
60
)
8
--
{-
{-
cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
cleanEnv env = do
cleanEnv env = do
r <- takeMVar (env ^. repoEnv . renv_var)
r <- takeMVar (env ^. repoEnv . renv_var)
...
...
src/Gargantext/API/Dev.hs
View file @
49436f17
...
@@ -23,6 +23,7 @@ import Gargantext.Core.NodeStory
...
@@ -23,6 +23,7 @@ import Gargantext.Core.NodeStory
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
GargConfig
(
..
),
readConfig
)
import
Gargantext.Prelude.Config
(
GargConfig
(
..
),
readConfig
)
import
qualified
Gargantext.Prelude.Mail
as
Mail
import
Servant
import
Servant
import
System.IO
(
FilePath
)
import
System.IO
(
FilePath
)
...
@@ -31,7 +32,7 @@ type IniPath = FilePath
...
@@ -31,7 +32,7 @@ type IniPath = FilePath
withDevEnv
::
IniPath
->
(
DevEnv
->
IO
a
)
->
IO
a
withDevEnv
::
IniPath
->
(
DevEnv
->
IO
a
)
->
IO
a
withDevEnv
iniPath
k
=
do
withDevEnv
iniPath
k
=
do
env
<-
newDevEnv
env
<-
newDevEnv
k
env
`
finally
`
cleanEnv
env
k
env
--
`finally` cleanEnv env
where
where
newDevEnv
=
do
newDevEnv
=
do
...
@@ -39,14 +40,14 @@ withDevEnv iniPath k = do
...
@@ -39,14 +40,14 @@ withDevEnv iniPath k = do
dbParam
<-
databaseParameters
iniPath
dbParam
<-
databaseParameters
iniPath
nodeStory_env
<-
readNodeStoryEnv
(
_gc_repofilepath
cfg
)
nodeStory_env
<-
readNodeStoryEnv
(
_gc_repofilepath
cfg
)
pool
<-
newPool
dbParam
pool
<-
newPool
dbParam
repo
<-
readRepoEnv
(
_gc_repofilepath
cfg
)
setts
<-
devSettings
devJwkFile
setts
<-
devSettings
devJwkFile
mail
<-
Mail
.
readConfig
iniPath
pure
$
DevEnv
pure
$
DevEnv
{
_dev_env_pool
=
pool
{
_dev_env_pool
=
pool
,
_dev_env_repo
=
repo
,
_dev_env_nodeStory
=
nodeStory_env
,
_dev_env_nodeStory
=
nodeStory_env
,
_dev_env_settings
=
setts
,
_dev_env_settings
=
setts
,
_dev_env_config
=
cfg
,
_dev_env_config
=
cfg
,
_dev_env_mail
=
mail
}
}
-- | Run Cmd Sugar for the Repl (GHCI)
-- | Run Cmd Sugar for the Repl (GHCI)
...
...
src/Gargantext/API/Ngrams.hs
View file @
49436f17
...
@@ -33,7 +33,6 @@ module Gargantext.API.Ngrams
...
@@ -33,7 +33,6 @@ module Gargantext.API.Ngrams
,
apiNgramsTableCorpus
,
apiNgramsTableCorpus
,
apiNgramsTableDoc
,
apiNgramsTableDoc
,
NgramsStatePatch
,
NgramsTablePatch
,
NgramsTablePatch
,
NgramsTableMap
,
NgramsTableMap
...
@@ -52,15 +51,10 @@ module Gargantext.API.Ngrams
...
@@ -52,15 +51,10 @@ module Gargantext.API.Ngrams
,
r_version
,
r_version
,
r_state
,
r_state
,
r_history
,
r_history
,
NgramsRepo
,
NgramsRepoElement
(
..
)
,
NgramsRepoElement
(
..
)
,
saveNodeStory
,
saveNodeStory
,
initRepo
,
initRepo
,
RepoEnv
(
..
)
,
renv_var
,
renv_lock
,
TabType
(
..
)
,
TabType
(
..
)
,
QueryParamR
,
QueryParamR
...
@@ -102,6 +96,7 @@ import Gargantext.API.Job
...
@@ -102,6 +96,7 @@ import Gargantext.API.Job
import
Gargantext.API.Ngrams.Types
import
Gargantext.API.Ngrams.Types
import
Gargantext.API.Prelude
import
Gargantext.API.Prelude
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Types
(
ListType
(
..
),
NodeId
,
ListId
,
DocId
,
Limit
,
Offset
,
TODO
,
assertValid
,
HasInvalidError
)
import
Gargantext.Core.Types
(
ListType
(
..
),
NodeId
,
ListId
,
DocId
,
Limit
,
Offset
,
TODO
,
assertValid
,
HasInvalidError
)
import
Gargantext.API.Ngrams.Tools
import
Gargantext.API.Ngrams.Tools
import
Gargantext.Database.Action.Flow.Types
import
Gargantext.Database.Action.Flow.Types
...
@@ -280,7 +275,7 @@ newNgramsFromNgramsStatePatch p =
...
@@ -280,7 +275,7 @@ newNgramsFromNgramsStatePatch p =
commitStatePatch
::
HasNodeStory
env
err
m
commitStatePatch
::
(
HasNodeStory
env
err
m
,
HasMail
env
)
=>
ListId
=>
ListId
->
Versioned
NgramsStatePatch'
->
Versioned
NgramsStatePatch'
->
m
(
Versioned
NgramsStatePatch'
)
->
m
(
Versioned
NgramsStatePatch'
)
...
@@ -346,8 +341,9 @@ tableNgramsPull listId ngramsType p_version = do
...
@@ -346,8 +341,9 @@ tableNgramsPull listId ngramsType p_version = do
-- client.
-- client.
-- TODO-ACCESS check
-- TODO-ACCESS check
tableNgramsPut
::
(
HasNodeStory
env
err
m
tableNgramsPut
::
(
HasNodeStory
env
err
m
,
HasInvalidError
err
,
HasInvalidError
err
,
HasSettings
env
,
HasSettings
env
,
HasMail
env
)
)
=>
TabType
=>
TabType
->
ListId
->
ListId
...
@@ -494,7 +490,7 @@ type MaxSize = Int
...
@@ -494,7 +490,7 @@ type MaxSize = Int
getTableNgrams
::
forall
env
err
m
.
getTableNgrams
::
forall
env
err
m
.
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
)
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
NodeType
->
NodeId
->
TabType
=>
NodeType
->
NodeId
->
TabType
->
ListId
->
Limit
->
Maybe
Offset
->
ListId
->
Limit
->
Maybe
Offset
->
Maybe
ListType
->
Maybe
ListType
...
@@ -617,7 +613,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
...
@@ -617,7 +613,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
scoresRecomputeTableNgrams
::
forall
env
err
m
.
scoresRecomputeTableNgrams
::
forall
env
err
m
.
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
)
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
NodeId
->
TabType
->
ListId
->
m
Int
=>
NodeId
->
TabType
->
ListId
->
m
Int
scoresRecomputeTableNgrams
nId
tabType
listId
=
do
scoresRecomputeTableNgrams
nId
tabType
listId
=
do
tableMap
<-
getNgramsTableMap
listId
ngramsType
tableMap
<-
getNgramsTableMap
listId
ngramsType
...
@@ -712,7 +708,7 @@ type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
...
@@ -712,7 +708,7 @@ type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
:>
"update"
:>
"update"
:>
AsyncJobs
JobLog
'[
J
SON
]
UpdateTableNgramsCharts
JobLog
:>
AsyncJobs
JobLog
'[
J
SON
]
UpdateTableNgramsCharts
JobLog
getTableNgramsCorpus
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
)
getTableNgramsCorpus
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
NodeId
=>
NodeId
->
TabType
->
TabType
->
ListId
->
ListId
...
@@ -746,7 +742,7 @@ getTableNgramsVersion _nId _tabType listId = currentVersion listId
...
@@ -746,7 +742,7 @@ getTableNgramsVersion _nId _tabType listId = currentVersion listId
-- | Text search is deactivated for now for ngrams by doc only
-- | Text search is deactivated for now for ngrams by doc only
getTableNgramsDoc
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
)
getTableNgramsDoc
::
(
HasNodeStory
env
err
m
,
HasNodeError
err
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
=>
DocId
->
TabType
=>
DocId
->
TabType
->
ListId
->
Limit
->
Maybe
Offset
->
ListId
->
Limit
->
Maybe
Offset
->
Maybe
ListType
->
Maybe
ListType
...
...
src/Gargantext/API/Ngrams/Tools.hs
View file @
49436f17
...
@@ -35,12 +35,12 @@ mergeNgramsElement _neOld neNew = neNew
...
@@ -35,12 +35,12 @@ mergeNgramsElement _neOld neNew = neNew
type
RootTerm
=
NgramsTerm
type
RootTerm
=
NgramsTerm
{-
getRepo :: RepoCmdM env err m => m NgramsRepo
getRepo :: RepoCmdM env err m => m NgramsRepo
getRepo = do
getRepo = do
v <- view repoVar
v <- view repoVar
liftBase $ readMVar v
liftBase $ readMVar v
-}
getRepo'
::
HasNodeStory
env
err
m
getRepo'
::
HasNodeStory
env
err
m
=>
[
ListId
]
->
m
NodeListStory
=>
[
ListId
]
->
m
NodeListStory
...
...
src/Gargantext/API/Ngrams/Types.hs
View file @
49436f17
...
@@ -11,8 +11,7 @@ module Gargantext.API.Ngrams.Types where
...
@@ -11,8 +11,7 @@ module Gargantext.API.Ngrams.Types where
import
Codec.Serialise
(
Serialise
())
import
Codec.Serialise
(
Serialise
())
import
Control.Category
((
>>>
))
import
Control.Category
((
>>>
))
import
Control.Concurrent
import
Control.Lens
(
makeLenses
,
makePrisms
,
Iso
'
,
iso
,
from
,
(
.~
),
(
?=
),
(
#
),
to
,
folded
,
{-withIndex, ifolded,-}
view
,
use
,
(
^.
),
(
^?
),
(
%~
),
(
.~
),
(
%=
),
at
,
_Just
,
Each
(
..
),
itraverse_
,
both
,
forOf_
,
(
?~
))
import
Control.Lens
(
makeLenses
,
makePrisms
,
Iso
'
,
iso
,
from
,
(
.~
),
(
?=
),
(
#
),
to
,
folded
,
{-withIndex, ifolded,-}
view
,
use
,
(
^.
),
(
^?
),
(
%~
),
(
.~
),
(
%=
),
at
,
_Just
,
Each
(
..
),
itraverse_
,
both
,
forOf_
,
(
?~
),
Getter
)
import
Control.Monad.State
import
Control.Monad.State
import
Data.Aeson
hiding
((
.=
))
import
Data.Aeson
hiding
((
.=
))
import
Data.Aeson.TH
(
deriveJSON
)
import
Data.Aeson.TH
(
deriveJSON
)
...
@@ -39,7 +38,7 @@ import Gargantext.Prelude.Crypto.Hash (IsHashable(..))
...
@@ -39,7 +38,7 @@ import Gargantext.Prelude.Crypto.Hash (IsHashable(..))
import
Protolude
(
maybeToEither
)
import
Protolude
(
maybeToEither
)
import
Servant
hiding
(
Patch
)
import
Servant
hiding
(
Patch
)
import
Servant.Job.Utils
(
jsonOptions
)
import
Servant.Job.Utils
(
jsonOptions
)
import
System.FileLock
(
FileLock
)
--
import System.FileLock (FileLock)
import
Test.QuickCheck
(
elements
,
frequency
)
import
Test.QuickCheck
(
elements
,
frequency
)
import
Test.QuickCheck.Arbitrary
(
Arbitrary
,
arbitrary
)
import
Test.QuickCheck.Arbitrary
(
Arbitrary
,
arbitrary
)
import
qualified
Data.HashMap.Strict.InsOrd
as
InsOrdHashMap
import
qualified
Data.HashMap.Strict.InsOrd
as
InsOrdHashMap
...
@@ -676,11 +675,6 @@ data Repo s p = Repo
...
@@ -676,11 +675,6 @@ data Repo s p = Repo
}
}
deriving
(
Generic
,
Show
)
deriving
(
Generic
,
Show
)
-- | TO REMOVE
type
NgramsRepo
=
Repo
NgramsState
NgramsStatePatch
type
NgramsState
=
Map
TableNgrams
.
NgramsType
(
Map
NodeId
NgramsTableMap
)
type
NgramsStatePatch
=
PatchMap
TableNgrams
.
NgramsType
(
PatchMap
NodeId
NgramsTablePatch
)
----------------------------------------------------------------------
----------------------------------------------------------------------
instance
(
FromJSON
s
,
FromJSON
p
)
=>
FromJSON
(
Repo
s
p
)
where
instance
(
FromJSON
s
,
FromJSON
p
)
=>
FromJSON
(
Repo
s
p
)
where
...
@@ -697,52 +691,16 @@ makeLenses ''Repo
...
@@ -697,52 +691,16 @@ makeLenses ''Repo
initRepo
::
Monoid
s
=>
Repo
s
p
initRepo
::
Monoid
s
=>
Repo
s
p
initRepo
=
Repo
1
mempty
[]
initRepo
=
Repo
1
mempty
[]
instance
Serialise
(
PM
.
PatchMap
NodeId
NgramsTablePatch
)
instance
Serialise
NgramsStatePatch
initMockRepo
::
NgramsRepo
initMockRepo
=
Repo
1
s
[]
where
s
=
Map
.
singleton
TableNgrams
.
NgramsTerms
$
Map
.
singleton
47254
$
Map
.
fromList
[
(
n
^.
ne_ngrams
,
ngramsElementToRepo
n
)
|
n
<-
mockTable
^.
_NgramsTable
]
--------------------
--------------------
data
RepoEnv
=
RepoEnv
{
_renv_var
::
!
(
MVar
NgramsRepo
)
,
_renv_saver
::
!
(
IO
()
)
,
_renv_lock
::
!
FileLock
}
deriving
(
Generic
)
makeLenses
''
R
epoEnv
type
RepoCmdM
env
err
m
=
type
RepoCmdM
env
err
m
=
(
CmdM'
env
err
m
(
CmdM'
env
err
m
,
HasRepo
env
,
HasConnectionPool
env
,
HasConnectionPool
env
,
HasConfig
env
,
HasConfig
env
)
)
class
(
HasRepoVar
env
,
HasRepoSaver
env
)
=>
HasRepo
env
where
repoEnv
::
Getter
env
RepoEnv
class
HasRepoVar
env
where
repoVar
::
Getter
env
(
MVar
NgramsRepo
)
class
HasRepoSaver
env
where
repoSaver
::
Getter
env
(
IO
()
)
instance
HasRepo
RepoEnv
where
repoEnv
=
identity
instance
HasRepoVar
(
MVar
NgramsRepo
)
where
repoVar
=
identity
instance
HasRepoVar
RepoEnv
where
repoVar
=
renv_var
instance
HasRepoSaver
RepoEnv
where
repoSaver
=
renv_saver
------------------------------------------------------------------------
------------------------------------------------------------------------
...
...
src/Gargantext/API/Node/Contact.hs
View file @
49436f17
...
@@ -93,7 +93,7 @@ addContact u nId (AddContactParams fn ln) logStatus = do
...
@@ -93,7 +93,7 @@ addContact u nId (AddContactParams fn ln) logStatus = do
,
_scst_remaining
=
Just
1
,
_scst_remaining
=
Just
1
,
_scst_events
=
Just
[]
,
_scst_events
=
Just
[]
}
}
_
<-
flow
(
Nothing
::
Maybe
HyperdataAnnuaire
)
u
(
Right
[
nId
])
(
Multi
EN
)
Nothing
[[
hyperdataContact
fn
ln
]]
_
<-
flow
(
Nothing
::
Maybe
HyperdataAnnuaire
)
u
(
Right
[
nId
])
(
Multi
EN
)
Nothing
[[
hyperdataContact
fn
ln
]]
logStatus
pure
JobLog
{
_scst_succeeded
=
Just
2
pure
JobLog
{
_scst_succeeded
=
Just
2
,
_scst_failed
=
Just
0
,
_scst_failed
=
Just
0
...
...
src/Gargantext/API/Node/Corpus/New.hs
View file @
49436f17
...
@@ -213,15 +213,15 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
...
@@ -213,15 +213,15 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
-- TODO if cid is folder -> create Corpus
-- TODO if cid is folder -> create Corpus
-- if cid is corpus -> add to corpus
-- if cid is corpus -> add to corpus
-- if cid is root -> create corpus in Private
-- if cid is root -> create corpus in Private
txts
<-
mapM
(
\
db
->
getDataText
db
(
Multi
l
)
q
maybeLimit
)
[
database2origin
dbs
]
txts
<-
mapM
(
\
db
->
getDataText
db
(
Multi
l
)
q
maybeLimit
)
[
database2origin
dbs
]
logStatus
JobLog
{
_scst_succeeded
=
Just
2
logStatus
JobLog
{
_scst_succeeded
=
Just
2
,
_scst_failed
=
Just
0
,
_scst_failed
=
Just
0
,
_scst_remaining
=
Just
1
,
_scst_remaining
=
Just
$
1
+
length
txts
,
_scst_events
=
Just
[]
,
_scst_events
=
Just
[]
}
}
cids
<-
mapM
(
\
txt
->
flowDataText
user
txt
(
Multi
l
)
cid
Nothing
)
txts
cids
<-
mapM
(
\
txt
->
flowDataText
user
txt
(
Multi
l
)
cid
Nothing
logStatus
)
txts
printDebug
"corpus id"
cids
printDebug
"corpus id"
cids
printDebug
"sending email"
(
"xxxxxxxxxxxxxxxxxxxxx"
::
Text
)
printDebug
"sending email"
(
"xxxxxxxxxxxxxxxxxxxxx"
::
Text
)
sendMail
user
sendMail
user
...
@@ -297,6 +297,7 @@ addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus jobLog = do
...
@@ -297,6 +297,7 @@ addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus jobLog = do
(
Multi
$
fromMaybe
EN
l
)
(
Multi
$
fromMaybe
EN
l
)
Nothing
Nothing
(
map
(
map
toHyperdataDocument
)
docs
)
(
map
(
map
toHyperdataDocument
)
docs
)
logStatus
printDebug
"Extraction finished : "
cid
printDebug
"Extraction finished : "
cid
printDebug
"sending email"
(
"xxxxxxxxxxxxxxxxxxxxx"
::
Text
)
printDebug
"sending email"
(
"xxxxxxxxxxxxxxxxxxxxx"
::
Text
)
...
...
src/Gargantext/API/Node/Corpus/New/File.hs
View file @
49436f17
...
@@ -63,6 +63,7 @@ instance FromHttpApiData FileType
...
@@ -63,6 +63,7 @@ instance FromHttpApiData FileType
parseUrlPiece
"CSV_HAL"
=
pure
CSV_HAL
parseUrlPiece
"CSV_HAL"
=
pure
CSV_HAL
parseUrlPiece
"PresseRis"
=
pure
PresseRIS
parseUrlPiece
"PresseRis"
=
pure
PresseRIS
parseUrlPiece
"ZIP"
=
pure
ZIP
parseUrlPiece
"ZIP"
=
pure
ZIP
parseUrlPiece
"WOS"
=
pure
WOS
parseUrlPiece
_
=
pure
CSV
-- TODO error here
parseUrlPiece
_
=
pure
CSV
-- TODO error here
...
...
src/Gargantext/API/Node/DocumentUpload.hs
View file @
49436f17
...
@@ -107,6 +107,6 @@ documentUpload uId nId doc logStatus = do
...
@@ -107,6 +107,6 @@ documentUpload uId nId doc logStatus = do
,
_hd_publication_minute
=
Nothing
,
_hd_publication_minute
=
Nothing
,
_hd_publication_second
=
Nothing
,
_hd_publication_second
=
Nothing
,
_hd_language_iso2
=
Just
$
T
.
pack
$
show
EN
}
,
_hd_language_iso2
=
Just
$
T
.
pack
$
show
EN
}
_
<-
flowDataText
(
RootId
(
NodeId
uId
))
(
DataNew
[[
hd
]])
(
Multi
EN
)
cId
Nothing
_
<-
flowDataText
(
RootId
(
NodeId
uId
))
(
DataNew
[[
hd
]])
(
Multi
EN
)
cId
Nothing
logStatus
pure
$
jobLogSuccess
jl
pure
$
jobLogSuccess
jl
src/Gargantext/API/Node/DocumentsFromWriteNodes.hs
View file @
49436f17
...
@@ -100,7 +100,7 @@ documentsFromWriteNodes uId nId _p logStatus = do
...
@@ -100,7 +100,7 @@ documentsFromWriteNodes uId nId _p logStatus = do
let
parsedE
=
(
\
(
node
,
contents
)
->
hyperdataDocumentFromFrameWrite
(
node
^.
node_hyperdata
,
contents
))
<$>
frameWritesWithContents
let
parsedE
=
(
\
(
node
,
contents
)
->
hyperdataDocumentFromFrameWrite
(
node
^.
node_hyperdata
,
contents
))
<$>
frameWritesWithContents
let
parsed
=
rights
parsedE
let
parsed
=
rights
parsedE
_
<-
flowDataText
(
RootId
(
NodeId
uId
))
(
DataNew
[
parsed
])
(
Multi
EN
)
cId
Nothing
_
<-
flowDataText
(
RootId
(
NodeId
uId
))
(
DataNew
[
parsed
])
(
Multi
EN
)
cId
Nothing
logStatus
pure
$
jobLogSuccess
jobLog
pure
$
jobLogSuccess
jobLog
------------------------------------------------------------------------
------------------------------------------------------------------------
...
...
src/Gargantext/API/Prelude.hs
View file @
49436f17
...
@@ -34,6 +34,7 @@ import Data.Validity
...
@@ -34,6 +34,7 @@ import Data.Validity
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Admin.Types
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Types
import
Gargantext.Core.Types
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node.Error
(
NodeError
(
..
),
HasNodeError
(
..
))
import
Gargantext.Database.Query.Table.Node.Error
(
NodeError
(
..
),
HasNodeError
(
..
))
...
@@ -54,7 +55,8 @@ type EnvC env =
...
@@ -54,7 +55,8 @@ type EnvC env =
,
HasSettings
env
-- TODO rename HasDbSettings
,
HasSettings
env
-- TODO rename HasDbSettings
,
HasJobEnv
env
JobLog
JobLog
,
HasJobEnv
env
JobLog
JobLog
,
HasConfig
env
,
HasConfig
env
,
HasNodeStoryEnv
env
,
HasNodeStoryEnv
env
,
HasMail
env
)
)
type
ErrC
err
=
type
ErrC
err
=
...
...
src/Gargantext/Core/Mail.hs
View file @
49436f17
...
@@ -7,19 +7,19 @@ Maintainer : team@gargantext.org
...
@@ -7,19 +7,19 @@ Maintainer : team@gargantext.org
Stability : experimental
Stability : experimental
Portability : POSIX
Portability : POSIX
TODO put main configuration variables in gargantext.ini
-}
-}
module
Gargantext.Core.Mail
module
Gargantext.Core.Mail
where
where
import
Control.Lens
((
^.
))
import
Data.Text
(
Text
,
unlines
,
splitOn
)
import
Data.Text
(
Text
,
unlines
,
splitOn
)
import
Gargantext.Core.Types.Individu
import
Gargantext.Core.Types.Individu
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Mail
(
gargMail
,
GargMail
(
..
))
import
Gargantext.Prelude.Mail
(
gargMail
,
GargMail
(
..
))
import
Gargantext.Prelude.Mail.Types
(
MailConfig
,
mc_mail_host
)
import
qualified
Data.List
as
List
import
qualified
Data.List
as
List
-- | Tool to put elsewhere
-- | Tool to put elsewhere
isEmail
::
Text
->
Bool
isEmail
::
Text
->
Bool
isEmail
=
((
==
)
2
)
.
List
.
length
.
(
splitOn
"@"
)
isEmail
=
((
==
)
2
)
.
List
.
length
.
(
splitOn
"@"
)
...
@@ -38,12 +38,12 @@ data MailModel = Invitation { invitation_user :: NewUser GargPassword }
...
@@ -38,12 +38,12 @@ data MailModel = Invitation { invitation_user :: NewUser GargPassword }
}
}
------------------------------------------------------------------------
------------------------------------------------------------------------
------------------------------------------------------------------------
------------------------------------------------------------------------
mail
::
ServerAddress
->
MailModel
->
IO
()
mail
::
MailConfig
->
MailModel
->
IO
()
mail
server
model
=
gargMail
(
GargMail
m
(
Just
u
)
subject
body
)
mail
cfg
model
=
gargMail
cfg
(
GargMail
m
(
Just
u
)
subject
body
)
where
where
(
m
,
u
)
=
email_to
model
(
m
,
u
)
=
email_to
model
subject
=
email_subject
model
subject
=
email_subject
model
body
=
emailWith
server
model
body
=
emailWith
(
cfg
^.
mc_mail_host
)
model
------------------------------------------------------------------------
------------------------------------------------------------------------
emailWith
::
ServerAddress
->
MailModel
->
Text
emailWith
::
ServerAddress
->
MailModel
->
Text
...
...
src/Gargantext/Core/Mail/Types.hs
0 → 100644
View file @
49436f17
{-|
Module : Gargantext.Core.Mail.Types
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
module
Gargantext.Core.Mail.Types
where
import
Control.Lens
(
Getter
)
import
Gargantext.Prelude.Mail.Types
(
MailConfig
)
class
HasMail
env
where
mailSettings
::
Getter
env
MailConfig
src/Gargantext/Core/NodeStory.hs
View file @
49436f17
...
@@ -32,7 +32,6 @@ import Control.Monad.Except
...
@@ -32,7 +32,6 @@ import Control.Monad.Except
import
Control.Monad.Reader
import
Control.Monad.Reader
import
Data.Aeson
hiding
((
.=
),
decode
)
import
Data.Aeson
hiding
((
.=
),
decode
)
import
Data.Map.Strict
(
Map
)
import
Data.Map.Strict
(
Map
)
import
Data.Maybe
(
fromMaybe
)
import
Data.Monoid
import
Data.Monoid
import
Data.Semigroup
import
Data.Semigroup
import
GHC.Generics
(
Generic
)
import
GHC.Generics
(
Generic
)
...
@@ -48,7 +47,6 @@ import System.IO.Temp (withTempFile)
...
@@ -48,7 +47,6 @@ import System.IO.Temp (withTempFile)
import
qualified
Data.ByteString.Lazy
as
DBL
import
qualified
Data.ByteString.Lazy
as
DBL
import
qualified
Data.List
as
List
import
qualified
Data.List
as
List
import
qualified
Data.Map.Strict
as
Map
import
qualified
Data.Map.Strict
as
Map
import
qualified
Data.Map.Strict.Patch.Internal
as
Patch
import
qualified
Gargantext.Database.Query.Table.Ngrams
as
TableNgrams
import
qualified
Gargantext.Database.Query.Table.Ngrams
as
TableNgrams
------------------------------------------------------------------------
------------------------------------------------------------------------
...
@@ -207,6 +205,7 @@ nodeStoryPath repoDir nId = repoDir <> "/" <> filename
...
@@ -207,6 +205,7 @@ nodeStoryPath repoDir nId = repoDir <> "/" <> filename
------------------------------------------------------------------------
------------------------------------------------------------------------
-- TODO : repo Migration TODO TESTS
-- TODO : repo Migration TODO TESTS
{-
repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
...
@@ -249,7 +248,7 @@ ngramsStatePatch_migration np' = Map.fromListWith (<>)
...
@@ -249,7 +248,7 @@ ngramsStatePatch_migration np' = Map.fromListWith (<>)
-> (nid, [fst $ Patch.singleton nt table])
-> (nid, [fst $ Patch.singleton nt table])
) $ Patch.toList nTable
) $ Patch.toList nTable
) $ Patch.toList p
) $ Patch.toList p
-}
------------------------------------------------------------------------
------------------------------------------------------------------------
{- | Node Story for each NodeType where the Key of the Map is NodeId
{- | Node Story for each NodeType where the Key of the Map is NodeId
...
...
src/Gargantext/Database/Action/Delete.hs
View file @
49436f17
...
@@ -21,25 +21,26 @@ import Control.Lens (view, (^.))
...
@@ -21,25 +21,26 @@ import Control.Lens (view, (^.))
import
Data.Text
import
Data.Text
import
Servant
import
Servant
import
Gargantext.Core
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.Action.User
(
getUserId
)
import
Gargantext.Database.Action.Share
(
delFolderTeam
)
import
Gargantext.Database.Action.Share
(
delFolderTeam
)
import
Gargantext.
Core
import
Gargantext.
Database.Action.User
(
getUserId
)
import
Gargantext.Database.Admin.Types.Hyperdata.File
import
Gargantext.Database.Admin.Types.Hyperdata.File
import
Gargantext.Database.Admin.Types.Node
-- (NodeType(..))
import
Gargantext.Database.Admin.Types.Node
-- (NodeType(..))
import
Gargantext.Database.Prelude
(
Cmd
'
,
HasConfig
,
HasConnectionPool
)
import
Gargantext.Database.Prelude
(
Cmd
'
,
HasConfig
,
HasConnectionPool
)
import
qualified
Gargantext.Database.Query.Table.Node
as
N
(
getNode
,
deleteNode
)
import
Gargantext.Database.Query.Table.Node
(
getNodeWith
)
import
Gargantext.Database.Query.Table.Node
(
getNodeWith
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Schema.Node
import
Gargantext.Database.Schema.Node
import
Gargantext.Prelude
import
Gargantext.Prelude
import
qualified
Gargantext.Database.GargDB
as
GargDB
import
qualified
Gargantext.Database.GargDB
as
GargDB
import
qualified
Gargantext.Database.Query.Table.Node
as
N
(
getNode
,
deleteNode
)
------------------------------------------------------------------------
------------------------------------------------------------------------
-- TODO
-- TODO
-- Delete Corpus children accoring its types
-- Delete Corpus children accoring its types
-- Delete NodeList (NodeStory + cbor file)
-- Delete NodeList (NodeStory + cbor file)
deleteNode
::
(
HasConfig
env
,
HasConnectionPool
env
,
HasNodeError
err
)
deleteNode
::
(
Has
Mail
env
,
Has
Config
env
,
HasConnectionPool
env
,
HasNodeError
err
)
=>
User
=>
User
->
NodeId
->
NodeId
->
Cmd'
env
err
Int
->
Cmd'
env
err
Int
...
...
src/Gargantext/Database/Action/Flow.hs
View file @
49436f17
...
@@ -65,6 +65,7 @@ import qualified Data.HashMap.Strict as HashMap
...
@@ -65,6 +65,7 @@ import qualified Data.HashMap.Strict as HashMap
import
qualified
Gargantext.Data.HashMap.Strict.Utils
as
HashMap
import
qualified
Gargantext.Data.HashMap.Strict.Utils
as
HashMap
import
qualified
Data.Map
as
Map
import
qualified
Data.Map
as
Map
import
Gargantext.API.Admin.Orchestrator.Types
(
JobLog
(
..
))
import
Gargantext.Core
(
Lang
(
..
),
PosTagAlgo
(
..
))
import
Gargantext.Core
(
Lang
(
..
),
PosTagAlgo
(
..
))
import
Gargantext.Core.Ext.IMT
(
toSchoolName
)
import
Gargantext.Core.Ext.IMT
(
toSchoolName
)
import
Gargantext.Core.Ext.IMTUser
(
readFile_Annuaire
)
import
Gargantext.Core.Ext.IMTUser
(
readFile_Annuaire
)
...
@@ -154,11 +155,12 @@ flowDataText :: ( FlowCmdM env err m
...
@@ -154,11 +155,12 @@ flowDataText :: ( FlowCmdM env err m
->
TermType
Lang
->
TermType
Lang
->
CorpusId
->
CorpusId
->
Maybe
FlowSocialListWith
->
Maybe
FlowSocialListWith
->
(
JobLog
->
m
()
)
->
m
CorpusId
->
m
CorpusId
flowDataText
u
(
DataOld
ids
)
tt
cid
mfslw
=
flowCorpusUser
(
_tt_lang
tt
)
u
(
Right
[
cid
])
corpusType
ids
mfslw
flowDataText
u
(
DataOld
ids
)
tt
cid
mfslw
_
=
flowCorpusUser
(
_tt_lang
tt
)
u
(
Right
[
cid
])
corpusType
ids
mfslw
where
where
corpusType
=
(
Nothing
::
Maybe
HyperdataCorpus
)
corpusType
=
(
Nothing
::
Maybe
HyperdataCorpus
)
flowDataText
u
(
DataNew
txt
)
tt
cid
mfslw
=
flowCorpus
u
(
Right
[
cid
])
tt
mfslw
txt
flowDataText
u
(
DataNew
txt
)
tt
cid
mfslw
logStatus
=
flowCorpus
u
(
Right
[
cid
])
tt
mfslw
txt
logStatus
------------------------------------------------------------------------
------------------------------------------------------------------------
-- TODO use proxy
-- TODO use proxy
...
@@ -167,10 +169,11 @@ flowAnnuaire :: (FlowCmdM env err m)
...
@@ -167,10 +169,11 @@ flowAnnuaire :: (FlowCmdM env err m)
->
Either
CorpusName
[
CorpusId
]
->
Either
CorpusName
[
CorpusId
]
->
(
TermType
Lang
)
->
(
TermType
Lang
)
->
FilePath
->
FilePath
->
(
JobLog
->
m
()
)
->
m
AnnuaireId
->
m
AnnuaireId
flowAnnuaire
u
n
l
filePath
=
do
flowAnnuaire
u
n
l
filePath
logStatus
=
do
docs
<-
liftBase
$
((
splitEvery
500
<$>
readFile_Annuaire
filePath
)
::
IO
[[
HyperdataContact
]])
docs
<-
liftBase
$
((
splitEvery
500
<$>
readFile_Annuaire
filePath
)
::
IO
[[
HyperdataContact
]])
flow
(
Nothing
::
Maybe
HyperdataAnnuaire
)
u
n
l
Nothing
docs
flow
(
Nothing
::
Maybe
HyperdataAnnuaire
)
u
n
l
Nothing
docs
logStatus
------------------------------------------------------------------------
------------------------------------------------------------------------
flowCorpusFile
::
(
FlowCmdM
env
err
m
)
flowCorpusFile
::
(
FlowCmdM
env
err
m
)
...
@@ -179,13 +182,14 @@ flowCorpusFile :: (FlowCmdM env err m)
...
@@ -179,13 +182,14 @@ flowCorpusFile :: (FlowCmdM env err m)
->
Limit
-- Limit the number of docs (for dev purpose)
->
Limit
-- Limit the number of docs (for dev purpose)
->
TermType
Lang
->
FileFormat
->
FilePath
->
TermType
Lang
->
FileFormat
->
FilePath
->
Maybe
FlowSocialListWith
->
Maybe
FlowSocialListWith
->
(
JobLog
->
m
()
)
->
m
CorpusId
->
m
CorpusId
flowCorpusFile
u
n
l
la
ff
fp
mfslw
=
do
flowCorpusFile
u
n
l
la
ff
fp
mfslw
logStatus
=
do
eParsed
<-
liftBase
$
parseFile
ff
fp
eParsed
<-
liftBase
$
parseFile
ff
fp
case
eParsed
of
case
eParsed
of
Right
parsed
->
do
Right
parsed
->
do
let
docs
=
splitEvery
500
$
take
l
parsed
let
docs
=
splitEvery
500
$
take
l
parsed
flowCorpus
u
n
la
mfslw
(
map
(
map
toHyperdataDocument
)
docs
)
flowCorpus
u
n
la
mfslw
(
map
(
map
toHyperdataDocument
)
docs
)
logStatus
Left
e
->
panic
$
"Error: "
<>
(
T
.
pack
e
)
Left
e
->
panic
$
"Error: "
<>
(
T
.
pack
e
)
------------------------------------------------------------------------
------------------------------------------------------------------------
...
@@ -197,6 +201,7 @@ flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
...
@@ -197,6 +201,7 @@ flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
->
TermType
Lang
->
TermType
Lang
->
Maybe
FlowSocialListWith
->
Maybe
FlowSocialListWith
->
[[
a
]]
->
[[
a
]]
->
(
JobLog
->
m
()
)
->
m
CorpusId
->
m
CorpusId
flowCorpus
=
flow
(
Nothing
::
Maybe
HyperdataCorpus
)
flowCorpus
=
flow
(
Nothing
::
Maybe
HyperdataCorpus
)
...
@@ -211,10 +216,19 @@ flow :: ( FlowCmdM env err m
...
@@ -211,10 +216,19 @@ flow :: ( FlowCmdM env err m
->
TermType
Lang
->
TermType
Lang
->
Maybe
FlowSocialListWith
->
Maybe
FlowSocialListWith
->
[[
a
]]
->
[[
a
]]
->
(
JobLog
->
m
()
)
->
m
CorpusId
->
m
CorpusId
flow
c
u
cn
la
mfslw
docs
=
do
flow
c
u
cn
la
mfslw
docs
logStatus
=
do
-- TODO if public insertMasterDocs else insertUserDocs
-- TODO if public insertMasterDocs else insertUserDocs
ids
<-
traverse
(
insertMasterDocs
c
la
)
docs
ids
<-
traverse
(
\
(
idx
,
doc
)
->
do
id
<-
insertMasterDocs
c
la
doc
logStatus
JobLog
{
_scst_succeeded
=
Just
$
1
+
idx
,
_scst_failed
=
Just
0
,
_scst_remaining
=
Just
$
length
docs
-
idx
,
_scst_events
=
Just
[]
}
pure
id
)
(
zip
[
1
..
]
docs
)
flowCorpusUser
(
la
^.
tt_lang
)
u
cn
c
(
concat
ids
)
mfslw
flowCorpusUser
(
la
^.
tt_lang
)
u
cn
c
(
concat
ids
)
mfslw
------------------------------------------------------------------------
------------------------------------------------------------------------
...
...
src/Gargantext/Database/Action/Mail.hs
View file @
49436f17
...
@@ -14,21 +14,21 @@ module Gargantext.Database.Action.Mail
...
@@ -14,21 +14,21 @@ module Gargantext.Database.Action.Mail
where
where
import
Control.Lens
(
view
)
import
Control.Lens
(
view
)
import
Gargantext.Prelude
import
Gargantext.Core.Mail
(
mail
,
MailModel
(
..
))
import
Gargantext.Core.Mail.Types
(
mailSettings
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.Action.User
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Core.Mail
import
Gargantext.Prelude.Config
import
Gargantext.Database.Schema.User
import
Gargantext.Database.Schema.User
import
Gargantext.Database.Action.User
import
Gargantext.Prelude
import
Gargantext.Core.Types.Individu
(
User
(
..
))
------------------------------------------------------------------------
------------------------------------------------------------------------
sendMail
::
HasNodeError
err
=>
User
->
Cmd
err
()
sendMail
::
HasNodeError
err
=>
User
->
Cmd
err
()
sendMail
u
=
do
sendMail
u
=
do
server
<-
view
$
hasConfig
.
gc_url
cfg
<-
view
$
mailSettings
userLight
<-
getUserLightDB
u
userLight
<-
getUserLightDB
u
liftBase
$
mail
server
(
MailInfo
{
mailInfo_username
=
userLight_username
userLight
liftBase
$
mail
cfg
(
MailInfo
{
mailInfo_username
=
userLight_username
userLight
,
mailInfo_address
=
userLight_email
userLight
})
,
mailInfo_address
=
userLight_email
userLight
})
src/Gargantext/Database/Action/Metrics.hs
View file @
49436f17
...
@@ -18,6 +18,7 @@ import Data.Vector (Vector)
...
@@ -18,6 +18,7 @@ import Data.Vector (Vector)
import
Gargantext.API.Ngrams.Tools
(
filterListWithRoot
,
groupNodesByNgrams
,
Diagonal
(
..
),
getCoocByNgrams
,
mapTermListRoot
,
RootTerm
,
getRepo'
)
import
Gargantext.API.Ngrams.Tools
(
filterListWithRoot
,
groupNodesByNgrams
,
Diagonal
(
..
),
getCoocByNgrams
,
mapTermListRoot
,
RootTerm
,
getRepo'
)
import
Gargantext.API.Ngrams.Types
(
TabType
(
..
),
ngramsTypeFromTabType
,
NgramsTerm
)
import
Gargantext.API.Ngrams.Types
(
TabType
(
..
),
ngramsTypeFromTabType
,
NgramsTerm
)
import
Gargantext.Core.Text.Metrics
(
scored
,
Scored
(
..
),
{-localMetrics, toScored-}
)
import
Gargantext.Core.Text.Metrics
(
scored
,
Scored
(
..
),
{-localMetrics, toScored-}
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Types
(
ListType
(
..
),
Limit
,
NodeType
(
..
))
import
Gargantext.Core.Types
(
ListType
(
..
),
Limit
,
NodeType
(
..
))
import
Gargantext.Core.NodeStory
import
Gargantext.Core.NodeStory
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
...
@@ -62,7 +63,7 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do
...
@@ -62,7 +63,7 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do
getNgrams
::
(
HasNodeStory
env
err
m
)
getNgrams
::
(
Has
Mail
env
,
Has
NodeStory
env
err
m
)
=>
CorpusId
->
Maybe
ListId
->
TabType
=>
CorpusId
->
Maybe
ListId
->
TabType
->
m
(
HashMap
NgramsTerm
(
ListType
,
Maybe
NgramsTerm
)
->
m
(
HashMap
NgramsTerm
(
ListType
,
Maybe
NgramsTerm
)
,
HashMap
NgramsTerm
(
Maybe
RootTerm
)
,
HashMap
NgramsTerm
(
Maybe
RootTerm
)
...
...
src/Gargantext/Database/Action/User/New.hs
View file @
49436f17
...
@@ -16,24 +16,25 @@ module Gargantext.Database.Action.User.New
...
@@ -16,24 +16,25 @@ module Gargantext.Database.Action.User.New
import
Control.Lens
(
view
)
import
Control.Lens
(
view
)
import
Control.Monad.Random
import
Control.Monad.Random
import
Data.Text
(
Text
,
splitOn
)
import
Data.Text
(
Text
,
splitOn
)
import
qualified
Data.Text
as
Text
import
Gargantext.Core.Mail
import
Gargantext.Core.Mail
import
Gargantext.Core.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Core.Types.Individu
import
Gargantext.Core.Types.Individu
import
Gargantext.Database.Action.Flow
(
getOrMkRoot
)
import
Gargantext.Database.Action.Flow
(
getOrMkRoot
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
),
nodeError
,
NodeError
(
..
))
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
),
nodeError
,
NodeError
(
..
))
import
Gargantext.Database.Query.Table.User
import
Gargantext.Database.Query.Table.User
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
import
Gargantext.Prelude.Crypto.Pass.User
(
gargPass
)
import
Gargantext.Prelude.Crypto.Pass.User
(
gargPass
)
import
qualified
Data.Text
as
Text
import
Gargantext.Prelude.Mail.Types
(
MailConfig
)
------------------------------------------------------------------------
------------------------------------------------------------------------
------------------------------------------------------------------------
------------------------------------------------------------------------
newUsers
::
(
CmdM
env
err
m
,
MonadRandom
m
,
HasNodeError
err
)
newUsers
::
(
CmdM
env
err
m
,
MonadRandom
m
,
HasNodeError
err
,
HasMail
env
)
=>
[
EmailAddress
]
->
m
Int64
=>
[
EmailAddress
]
->
m
Int64
newUsers
us
=
do
newUsers
us
=
do
us'
<-
mapM
newUserQuick
us
us'
<-
mapM
newUserQuick
us
url
<-
view
$
hasConfig
.
gc_url
config
<-
view
$
mailSettings
newUsers'
url
us'
newUsers'
config
us'
------------------------------------------------------------------------
------------------------------------------------------------------------
newUserQuick
::
(
MonadRandom
m
)
newUserQuick
::
(
MonadRandom
m
)
=>
Text
->
m
(
NewUser
GargPassword
)
=>
Text
->
m
(
NewUser
GargPassword
)
...
@@ -54,27 +55,27 @@ guessUserName n = case splitOn "@" n of
...
@@ -54,27 +55,27 @@ guessUserName n = case splitOn "@" n of
_
->
Nothing
_
->
Nothing
------------------------------------------------------------------------
------------------------------------------------------------------------
newUser'
::
HasNodeError
err
newUser'
::
HasNodeError
err
=>
ServerAddress
->
NewUser
GargPassword
->
Cmd
err
Int64
=>
MailConfig
->
NewUser
GargPassword
->
Cmd
err
Int64
newUser'
address
u
=
newUsers'
address
[
u
]
newUser'
cfg
u
=
newUsers'
cfg
[
u
]
newUsers'
::
HasNodeError
err
newUsers'
::
HasNodeError
err
=>
ServerAddress
->
[
NewUser
GargPassword
]
->
Cmd
err
Int64
=>
MailConfig
->
[
NewUser
GargPassword
]
->
Cmd
err
Int64
newUsers'
address
us
=
do
newUsers'
cfg
us
=
do
us'
<-
liftBase
$
mapM
toUserHash
us
us'
<-
liftBase
$
mapM
toUserHash
us
r
<-
insertUsers
$
map
toUserWrite
us'
r
<-
insertUsers
$
map
toUserWrite
us'
_
<-
mapM
getOrMkRoot
$
map
(
\
u
->
UserName
(
_nu_username
u
))
us
_
<-
mapM
getOrMkRoot
$
map
(
\
u
->
UserName
(
_nu_username
u
))
us
_
<-
liftBase
$
mapM
(
\
u
->
mail
address
(
Invitation
u
))
us
_
<-
liftBase
$
mapM
(
\
u
->
mail
cfg
(
Invitation
u
))
us
printDebug
"newUsers'"
us
printDebug
"newUsers'"
us
pure
r
pure
r
------------------------------------------------------------------------
------------------------------------------------------------------------
updateUser
::
HasNodeError
err
updateUser
::
HasNodeError
err
=>
SendEmail
->
Text
->
NewUser
GargPassword
->
Cmd
err
Int64
=>
SendEmail
->
MailConfig
->
NewUser
GargPassword
->
Cmd
err
Int64
updateUser
(
SendEmail
send
)
server
u
=
do
updateUser
(
SendEmail
send
)
cfg
u
=
do
u'
<-
liftBase
$
toUserHash
u
u'
<-
liftBase
$
toUserHash
u
n
<-
updateUserDB
$
toUserWrite
u'
n
<-
updateUserDB
$
toUserWrite
u'
_
<-
case
send
of
_
<-
case
send
of
True
->
liftBase
$
mail
server
(
PassUpdate
u
)
True
->
liftBase
$
mail
cfg
(
PassUpdate
u
)
False
->
pure
()
False
->
pure
()
pure
n
pure
n
...
...
src/Gargantext/Database/Prelude.hs
View file @
49436f17
...
@@ -21,16 +21,17 @@ import Control.Monad.Reader
...
@@ -21,16 +21,17 @@ import Control.Monad.Reader
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
import
Data.Aeson
(
Result
(
Error
,
Success
),
fromJSON
,
FromJSON
)
import
Data.Aeson
(
Result
(
Error
,
Success
),
fromJSON
,
FromJSON
)
import
Data.ByteString.Char8
(
hPutStrLn
)
import
Data.ByteString.Char8
(
hPutStrLn
)
import
Data.Either.Extra
(
Either
(
Left
,
Right
))
import
Data.Either.Extra
(
Either
)
import
Data.Ini
(
readIniFile
,
lookupValue
)
import
Data.Pool
(
Pool
,
withResource
)
import
Data.Pool
(
Pool
,
withResource
)
import
Data.Profunctor.Product.Default
(
Default
)
import
Data.Profunctor.Product.Default
(
Default
)
import
Data.Text
(
unpack
,
pack
,
Text
)
import
Data.Text
(
unpack
,
Text
)
import
Data.Word
(
Word16
)
import
Data.Word
(
Word16
)
import
Database.PostgreSQL.Simple
(
Connection
,
connect
)
import
Database.PostgreSQL.Simple
(
Connection
,
connect
)
import
Database.PostgreSQL.Simple.FromField
(
Conversion
,
ResultError
(
ConversionFailed
),
fromField
,
returnError
)
import
Database.PostgreSQL.Simple.FromField
(
Conversion
,
ResultError
(
ConversionFailed
),
fromField
,
returnError
)
import
Database.PostgreSQL.Simple.Internal
(
Field
)
import
Database.PostgreSQL.Simple.Internal
(
Field
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
readIniFile'
,
val
)
import
Opaleye
(
Query
,
Unpackspec
,
showSql
,
FromFields
,
Select
,
runSelect
,
PGJsonb
,
DefaultFromField
)
import
Opaleye
(
Query
,
Unpackspec
,
showSql
,
FromFields
,
Select
,
runSelect
,
PGJsonb
,
DefaultFromField
)
import
Opaleye.Aggregate
(
countRows
)
import
Opaleye.Aggregate
(
countRows
)
import
System.IO
(
FilePath
)
import
System.IO
(
FilePath
)
...
@@ -77,13 +78,15 @@ type CmdM env err m =
...
@@ -77,13 +78,15 @@ type CmdM env err m =
(
CmdM'
env
err
m
(
CmdM'
env
err
m
,
HasConnectionPool
env
,
HasConnectionPool
env
,
HasConfig
env
,
HasConfig
env
,
HasMail
env
)
)
type
CmdRandom
env
err
m
=
type
CmdRandom
env
err
m
=
(
CmdM'
env
err
m
(
CmdM'
env
err
m
,
HasConnectionPool
env
,
HasConnectionPool
env
,
HasConfig
env
,
HasConfig
env
,
MonadRandom
m
,
MonadRandom
m
,
HasMail
env
)
)
type
Cmd''
env
err
a
=
forall
m
.
CmdM''
env
err
m
=>
m
a
type
Cmd''
env
err
a
=
forall
m
.
CmdM''
env
err
m
=>
m
a
...
@@ -157,20 +160,14 @@ execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
...
@@ -157,20 +160,14 @@ execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
databaseParameters
::
FilePath
->
IO
PGS
.
ConnectInfo
databaseParameters
::
FilePath
->
IO
PGS
.
ConnectInfo
databaseParameters
fp
=
do
databaseParameters
fp
=
do
ini
<-
readIniFile
fp
ini
<-
readIniFile'
fp
let
ini''
=
case
ini
of
let
val'
key
=
unpack
$
val
ini
"database"
key
Left
e
->
panic
(
pack
$
"No ini file error"
<>
show
e
)
Right
ini'
->
ini'
pure
$
PGS
.
ConnectInfo
{
PGS
.
connectHost
=
val'
"DB_HOST"
,
PGS
.
connectPort
=
read
(
val'
"DB_PORT"
)
::
Word16
let
val
x
=
case
(
lookupValue
(
pack
"database"
)
(
pack
x
)
ini''
)
of
,
PGS
.
connectUser
=
val'
"DB_USER"
Left
_
->
panic
(
pack
$
"no"
<>
x
)
,
PGS
.
connectPassword
=
val'
"DB_PASS"
Right
p'
->
unpack
p'
,
PGS
.
connectDatabase
=
val'
"DB_NAME"
pure
$
PGS
.
ConnectInfo
{
PGS
.
connectHost
=
val
"DB_HOST"
,
PGS
.
connectPort
=
read
(
val
"DB_PORT"
)
::
Word16
,
PGS
.
connectUser
=
val
"DB_USER"
,
PGS
.
connectPassword
=
val
"DB_PASS"
,
PGS
.
connectDatabase
=
val
"DB_NAME"
}
}
connectGargandb
::
FilePath
->
IO
Connection
connectGargandb
::
FilePath
->
IO
Connection
...
...
src/Gargantext/Database/Query/Table/NodesNgramsRepo.hs
View file @
49436f17
...
@@ -17,10 +17,9 @@ Portability : POSIX
...
@@ -17,10 +17,9 @@ Portability : POSIX
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TemplateHaskell #-}
module
Gargantext.Database.Query.Table.NodesNgramsRepo
module
Gargantext.Database.Query.Table.NodesNgramsRepo
(
module
Gargantext
.
Database
.
Schema
.
NodesNgramsRepo
)
where
where
{-
import Gargantext.Database.Schema.Prelude
import Gargantext.Database.Schema.Prelude
import Gargantext.API.Ngrams (NgramsStatePatch)
import Gargantext.API.Ngrams (NgramsStatePatch)
import Gargantext.Database.Schema.NodesNgramsRepo
import Gargantext.Database.Schema.NodesNgramsRepo
...
@@ -42,4 +41,4 @@ _insertRepos ns = mkCmd $ \conn -> runInsert_ conn $ Insert repoTable (toWrite n
...
@@ -42,4 +41,4 @@ _insertRepos ns = mkCmd $ \conn -> runInsert_ conn $ Insert repoTable (toWrite n
toWrite :: [NgramsStatePatch] -> [RepoDbWrite]
toWrite :: [NgramsStatePatch] -> [RepoDbWrite]
toWrite = undefined
toWrite = undefined
--ns' = map (\(RepoDbNgrams v ps) -> RepoDbWrite (sqlInt4 v) (pgJSONB ps)) ns
--ns' = map (\(RepoDbNgrams v ps) -> RepoDbWrite (sqlInt4 v) (pgJSONB ps)) ns
-}
src/Gargantext/Database/Schema/NodesNgramsRepo.hs
View file @
49436f17
...
@@ -21,10 +21,11 @@ Portability : POSIX
...
@@ -21,10 +21,11 @@ Portability : POSIX
module
Gargantext.Database.Schema.NodesNgramsRepo
module
Gargantext.Database.Schema.NodesNgramsRepo
where
where
{-
import Data.Map.Strict.Patch (PatchMap)
import Data.Map.Strict.Patch (PatchMap)
import Gargantext.Database.Schema.Prelude
import Gargantext.Database.Schema.Prelude
import
Gargantext.API.Ngrams.Types
(
Ngrams
StatePatch
,
Ngrams
TablePatch
)
import Gargantext.API.Ngrams.Types (NgramsTablePatch)
import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Prelude
import Gargantext.Prelude
...
@@ -59,4 +60,4 @@ repoTable = Table "nodes_ngrams_repo"
...
@@ -59,4 +60,4 @@ repoTable = Table "nodes_ngrams_repo"
, _rdp_patches = requiredTableField "patches"
, _rdp_patches = requiredTableField "patches"
}
}
)
)
-}
stack.yaml
View file @
49436f17
...
@@ -27,9 +27,8 @@ allow-newer: true
...
@@ -27,9 +27,8 @@ allow-newer: true
# "$everything": -haddock
# "$everything": -haddock
extra-deps
:
extra-deps
:
-
#git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
-
git
:
https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
git
:
https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude.git
commit
:
6bfdb29e9a576472c7fd7ebe648ad101e5b3927f
commit
:
35b09629a658fc16cc9ff63e7591e58511cd98a7
# Data Mining Libs
# Data Mining Libs
-
git
:
https://github.com/delanoe/data-time-segment.git
-
git
:
https://github.com/delanoe/data-time-segment.git
commit
:
10a416b9f6c443866b36479c3441ebb3bcdeb7ef
commit
:
10a416b9f6c443866b36479c3441ebb3bcdeb7ef
...
...
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