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
153
Issues
153
List
Board
Labels
Milestones
Merge Requests
12
Merge Requests
12
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
gargantext
haskell-gargantext
Commits
0c237cda
Commit
0c237cda
authored
Nov 10, 2021
by
Przemyslaw Kaminski
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[mail] add HasMail class, use gargantext.ini for config
parent
797e19df
Pipeline
#2067
failed with stage
in 10 minutes and 14 seconds
Changes
15
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
15 changed files
with
119 additions
and
74 deletions
+119
-74
gargantext.ini_toModify
gargantext.ini_toModify
+8
-0
Auth.hs
src/Gargantext/API/Admin/Auth.hs
+8
-6
EnvTypes.hs
src/Gargantext/API/Admin/EnvTypes.hs
+10
-2
Settings.hs
src/Gargantext/API/Admin/Settings.hs
+3
-0
Dev.hs
src/Gargantext/API/Dev.hs
+8
-5
Ngrams.hs
src/Gargantext/API/Ngrams.hs
+8
-6
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
Delete.hs
src/Gargantext/Database/Action/Delete.hs
+5
-4
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
stack.yaml
stack.yaml
+2
-3
No files found.
gargantext.ini_toModify
View file @
0c237cda
...
...
@@ -67,3 +67,11 @@ DB_PASS = PASSWORD_TO_CHANGE
LOG_FILE = /var/log/gargantext/backend.log
LOG_LEVEL = LevelDebug
LOG_FORMATTER = verbose
[mail]
MAIL_PORT = 25
MAIL_HOST = localhost
MAIL_USER = gargantext
MAIL_PASSWORD =
# Normal | SSL | TLS | STARTTLS
MAIL_LOGIN_TYPE = Normal
src/Gargantext/API/Admin/Auth.hs
View file @
0c237cda
...
...
@@ -20,6 +20,7 @@ TODO-ACCESS Critical
-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
module
Gargantext.API.Admin.Auth
...
...
@@ -35,17 +36,18 @@ import Servant
import
Servant.Auth.Server
import
qualified
Gargantext.Prelude.Crypto.Auth
as
Auth
import
Gargantext.API.Admin.Types
import
Gargantext.API.Admin.Auth.Types
import
Gargantext.API.Admin.Types
import
Gargantext.API.Prelude
(
HasJoseError
(
..
),
joseError
,
HasServerError
,
GargServerC
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
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.Root
(
getRoot
)
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.Database.Query.Table.User
---------------------------------------------------
...
...
@@ -60,7 +62,7 @@ makeTokenForUser uid = do
either
joseError
(
pure
.
toStrict
.
decodeUtf8
)
e
-- 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
->
GargPassword
->
Cmd'
env
err
CheckAuth
...
...
@@ -79,7 +81,7 @@ checkAuthRequest u (GargPassword p) = do
token
<-
makeTokenForUser
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
auth
(
AuthRequest
u
p
)
=
do
checkAuthRequest'
<-
checkAuthRequest
u
p
...
...
src/Gargantext/API/Admin/EnvTypes.hs
View file @
0c237cda
...
...
@@ -17,10 +17,12 @@ import qualified Servant.Job.Core
import
Gargantext.API.Ngrams.Types
(
HasRepoVar
(
..
),
HasRepoSaver
(
..
),
HasRepo
(
..
),
RepoEnv
(
..
))
import
Gargantext.API.Admin.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.Prelude
import
Gargantext.Prelude.Config
(
GargConfig
(
..
))
import
Gargantext.
Core.NodeStory
import
Gargantext.
Prelude.Mail.Types
(
MailConfig
)
data
Env
=
Env
{
_env_settings
::
!
Settings
...
...
@@ -32,6 +34,7 @@ data Env = Env
,
_env_self_url
::
!
BaseUrl
,
_env_scrapers
::
!
ScrapersEnv
,
_env_config
::
!
GargConfig
,
_env_mail
::
!
MailConfig
}
deriving
(
Generic
)
...
...
@@ -55,6 +58,9 @@ instance HasNodeStorySaver Env where
instance
HasSettings
Env
where
settings
=
env_settings
instance
HasMail
Env
where
mailSettings
=
env_mail
-- Specific to Repo
instance
HasRepoVar
Env
where
repoVar
=
repoEnv
.
repoVar
...
...
@@ -87,6 +93,7 @@ data DevEnv = DevEnv
,
_dev_env_config
::
!
GargConfig
,
_dev_env_pool
::
!
(
Pool
Connection
)
,
_dev_env_nodeStory
::
!
NodeStoryEnv
,
_dev_env_mail
::
!
MailConfig
}
makeLenses
''
D
evEnv
...
...
@@ -118,4 +125,5 @@ instance HasRepoSaver DevEnv where
instance
HasRepo
DevEnv
where
repoEnv
=
dev_env_repo
instance
HasMail
DevEnv
where
mailSettings
=
dev_env_mail
src/Gargantext/API/Admin/Settings.hs
View file @
0c237cda
...
...
@@ -47,6 +47,7 @@ import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_vers
import
Gargantext.Database.Prelude
(
databaseParameters
,
HasConfig
(
..
))
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
gc_repofilepath
)
import
qualified
Gargantext.Prelude.Mail
as
Mail
devSettings
::
FilePath
->
IO
Settings
devSettings
jwkFile
=
do
...
...
@@ -182,6 +183,7 @@ newEnv port file = do
nodeStory_env
<-
readNodeStoryEnv
(
_gc_repofilepath
config_env
)
scrapers_env
<-
newJobEnv
defaultSettings
manager_env
logger
<-
newStderrLoggerSet
defaultBufSize
config_mail
<-
Mail
.
readConfig
file
pure
$
Env
{
_env_settings
=
settings'
...
...
@@ -193,6 +195,7 @@ newEnv port file = do
,
_env_scrapers
=
scrapers_env
,
_env_self_url
=
self_url_env
,
_env_config
=
config_env
,
_env_mail
=
config_mail
}
newPool
::
ConnectInfo
->
IO
(
Pool
Connection
)
...
...
src/Gargantext/API/Dev.hs
View file @
0c237cda
...
...
@@ -23,6 +23,7 @@ import Gargantext.Core.NodeStory
import
Gargantext.Database.Prelude
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
GargConfig
(
..
),
readConfig
)
import
qualified
Gargantext.Prelude.Mail
as
Mail
import
Servant
import
System.IO
(
FilePath
)
...
...
@@ -41,12 +42,14 @@ withDevEnv iniPath k = do
pool
<-
newPool
dbParam
repo
<-
readRepoEnv
(
_gc_repofilepath
cfg
)
setts
<-
devSettings
devJwkFile
mail
<-
Mail
.
readConfig
iniPath
pure
$
DevEnv
{
_dev_env_pool
=
pool
,
_dev_env_repo
=
repo
,
_dev_env_nodeStory
=
nodeStory_env
,
_dev_env_settings
=
setts
,
_dev_env_config
=
cfg
{
_dev_env_pool
=
pool
,
_dev_env_repo
=
repo
,
_dev_env_nodeStory
=
nodeStory_env
,
_dev_env_settings
=
setts
,
_dev_env_config
=
cfg
,
_dev_env_mail
=
mail
}
-- | Run Cmd Sugar for the Repl (GHCI)
...
...
src/Gargantext/API/Ngrams.hs
View file @
0c237cda
...
...
@@ -102,6 +102,7 @@ import Gargantext.API.Job
import
Gargantext.API.Ngrams.Types
import
Gargantext.API.Prelude
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.API.Ngrams.Tools
import
Gargantext.Database.Action.Flow.Types
...
...
@@ -280,7 +281,7 @@ newNgramsFromNgramsStatePatch p =
commitStatePatch
::
HasNodeStory
env
err
m
commitStatePatch
::
(
HasNodeStory
env
err
m
,
HasMail
env
)
=>
ListId
->
Versioned
NgramsStatePatch'
->
m
(
Versioned
NgramsStatePatch'
)
...
...
@@ -346,8 +347,9 @@ tableNgramsPull listId ngramsType p_version = do
-- client.
-- TODO-ACCESS check
tableNgramsPut
::
(
HasNodeStory
env
err
m
,
HasInvalidError
err
,
HasInvalidError
err
,
HasSettings
env
,
HasMail
env
)
=>
TabType
->
ListId
...
...
@@ -494,7 +496,7 @@ type MaxSize = Int
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
->
ListId
->
Limit
->
Maybe
Offset
->
Maybe
ListType
...
...
@@ -617,7 +619,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
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
scoresRecomputeTableNgrams
nId
tabType
listId
=
do
tableMap
<-
getNgramsTableMap
listId
ngramsType
...
...
@@ -712,7 +714,7 @@ type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
:>
"update"
:>
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
->
TabType
->
ListId
...
...
@@ -746,7 +748,7 @@ getTableNgramsVersion _nId _tabType listId = currentVersion listId
-- | 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
->
ListId
->
Limit
->
Maybe
Offset
->
Maybe
ListType
...
...
src/Gargantext/API/Prelude.hs
View file @
0c237cda
...
...
@@ -34,6 +34,7 @@ import Data.Validity
import
Gargantext.API.Admin.Orchestrator.Types
import
Gargantext.API.Admin.Types
import
Gargantext.Core.NodeStory
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Types
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node.Error
(
NodeError
(
..
),
HasNodeError
(
..
))
...
...
@@ -54,7 +55,8 @@ type EnvC env =
,
HasSettings
env
-- TODO rename HasDbSettings
,
HasJobEnv
env
JobLog
JobLog
,
HasConfig
env
,
HasNodeStoryEnv
env
,
HasNodeStoryEnv
env
,
HasMail
env
)
type
ErrC
err
=
...
...
src/Gargantext/Core/Mail.hs
View file @
0c237cda
...
...
@@ -7,19 +7,19 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
TODO put main configuration variables in gargantext.ini
-}
module
Gargantext.Core.Mail
where
module
Gargantext.Core.Mail
where
import
Control.Lens
((
^.
))
import
Data.Text
(
Text
,
unlines
,
splitOn
)
import
Gargantext.Core.Types.Individu
import
Gargantext.Prelude
import
Gargantext.Prelude.Mail
(
gargMail
,
GargMail
(
..
))
import
Gargantext.Prelude.Mail.Types
(
MailConfig
,
mc_mail_host
)
import
qualified
Data.List
as
List
-- | Tool to put elsewhere
isEmail
::
Text
->
Bool
isEmail
=
((
==
)
2
)
.
List
.
length
.
(
splitOn
"@"
)
...
...
@@ -38,12 +38,12 @@ data MailModel = Invitation { invitation_user :: NewUser GargPassword }
}
------------------------------------------------------------------------
------------------------------------------------------------------------
mail
::
ServerAddress
->
MailModel
->
IO
()
mail
server
model
=
gargMail
(
GargMail
m
(
Just
u
)
subject
body
)
mail
::
MailConfig
->
MailModel
->
IO
()
mail
cfg
model
=
gargMail
cfg
(
GargMail
m
(
Just
u
)
subject
body
)
where
(
m
,
u
)
=
email_to
model
subject
=
email_subject
model
body
=
emailWith
server
model
body
=
emailWith
(
cfg
^.
mc_mail_host
)
model
------------------------------------------------------------------------
emailWith
::
ServerAddress
->
MailModel
->
Text
...
...
src/Gargantext/Core/Mail/Types.hs
0 → 100644
View file @
0c237cda
{-|
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/Database/Action/Delete.hs
View file @
0c237cda
...
...
@@ -21,25 +21,26 @@ import Control.Lens (view, (^.))
import
Data.Text
import
Servant
import
Gargantext.Core
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Database.Action.User
(
getUserId
)
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.Node
-- (NodeType(..))
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.Error
(
HasNodeError
)
import
Gargantext.Database.Schema.Node
import
Gargantext.Prelude
import
qualified
Gargantext.Database.GargDB
as
GargDB
import
qualified
Gargantext.Database.Query.Table.Node
as
N
(
getNode
,
deleteNode
)
------------------------------------------------------------------------
-- TODO
-- Delete Corpus children accoring its types
-- Delete NodeList (NodeStory + cbor file)
deleteNode
::
(
HasConfig
env
,
HasConnectionPool
env
,
HasNodeError
err
)
deleteNode
::
(
Has
Mail
env
,
Has
Config
env
,
HasConnectionPool
env
,
HasNodeError
err
)
=>
User
->
NodeId
->
Cmd'
env
err
Int
...
...
src/Gargantext/Database/Action/Mail.hs
View file @
0c237cda
...
...
@@ -14,21 +14,21 @@ module Gargantext.Database.Action.Mail
where
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.Query.Table.Node.Error
(
HasNodeError
(
..
))
import
Gargantext.Core.Mail
import
Gargantext.Prelude.Config
import
Gargantext.Database.Schema.User
import
Gargantext.Database.Action.User
import
Gargantext.Core.Types.Individu
(
User
(
..
))
import
Gargantext.Prelude
------------------------------------------------------------------------
sendMail
::
HasNodeError
err
=>
User
->
Cmd
err
()
sendMail
u
=
do
server
<-
view
$
hasConfig
.
gc_url
cfg
<-
view
$
mailSettings
userLight
<-
getUserLightDB
u
liftBase
$
mail
server
(
MailInfo
{
mailInfo_username
=
userLight_username
userLight
,
mailInfo_address
=
userLight_email
userLight
})
liftBase
$
mail
cfg
(
MailInfo
{
mailInfo_username
=
userLight_username
userLight
,
mailInfo_address
=
userLight_email
userLight
})
src/Gargantext/Database/Action/Metrics.hs
View file @
0c237cda
...
...
@@ -18,6 +18,7 @@ import Data.Vector (Vector)
import
Gargantext.API.Ngrams.Tools
(
filterListWithRoot
,
groupNodesByNgrams
,
Diagonal
(
..
),
getCoocByNgrams
,
mapTermListRoot
,
RootTerm
,
getRepo'
)
import
Gargantext.API.Ngrams.Types
(
TabType
(
..
),
ngramsTypeFromTabType
,
NgramsTerm
)
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.NodeStory
import
Gargantext.Database.Action.Flow.Types
(
FlowCmdM
)
...
...
@@ -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
->
m
(
HashMap
NgramsTerm
(
ListType
,
Maybe
NgramsTerm
)
,
HashMap
NgramsTerm
(
Maybe
RootTerm
)
...
...
src/Gargantext/Database/Action/User/New.hs
View file @
0c237cda
...
...
@@ -16,24 +16,25 @@ module Gargantext.Database.Action.User.New
import
Control.Lens
(
view
)
import
Control.Monad.Random
import
Data.Text
(
Text
,
splitOn
)
import
qualified
Data.Text
as
Text
import
Gargantext.Core.Mail
import
Gargantext.Core.Mail.Types
(
HasMail
,
mailSettings
)
import
Gargantext.Core.Types.Individu
import
Gargantext.Database.Action.Flow
(
getOrMkRoot
)
import
Gargantext.Database.Prelude
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
(
..
),
nodeError
,
NodeError
(
..
))
import
Gargantext.Database.Query.Table.User
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
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
newUsers
us
=
do
us'
<-
mapM
newUserQuick
us
url
<-
view
$
hasConfig
.
gc_url
newUsers'
url
us'
config
<-
view
$
mailSettings
newUsers'
config
us'
------------------------------------------------------------------------
newUserQuick
::
(
MonadRandom
m
)
=>
Text
->
m
(
NewUser
GargPassword
)
...
...
@@ -54,27 +55,27 @@ guessUserName n = case splitOn "@" n of
_
->
Nothing
------------------------------------------------------------------------
newUser'
::
HasNodeError
err
=>
ServerAddress
->
NewUser
GargPassword
->
Cmd
err
Int64
newUser'
address
u
=
newUsers'
address
[
u
]
=>
MailConfig
->
NewUser
GargPassword
->
Cmd
err
Int64
newUser'
cfg
u
=
newUsers'
cfg
[
u
]
newUsers'
::
HasNodeError
err
=>
ServerAddress
->
[
NewUser
GargPassword
]
->
Cmd
err
Int64
newUsers'
address
us
=
do
=>
MailConfig
->
[
NewUser
GargPassword
]
->
Cmd
err
Int64
newUsers'
cfg
us
=
do
us'
<-
liftBase
$
mapM
toUserHash
us
r
<-
insertUsers
$
map
toUserWrite
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
pure
r
------------------------------------------------------------------------
updateUser
::
HasNodeError
err
=>
SendEmail
->
Text
->
NewUser
GargPassword
->
Cmd
err
Int64
updateUser
(
SendEmail
send
)
server
u
=
do
=>
SendEmail
->
MailConfig
->
NewUser
GargPassword
->
Cmd
err
Int64
updateUser
(
SendEmail
send
)
cfg
u
=
do
u'
<-
liftBase
$
toUserHash
u
n
<-
updateUserDB
$
toUserWrite
u'
_
<-
case
send
of
True
->
liftBase
$
mail
server
(
PassUpdate
u
)
True
->
liftBase
$
mail
cfg
(
PassUpdate
u
)
False
->
pure
()
pure
n
...
...
src/Gargantext/Database/Prelude.hs
View file @
0c237cda
...
...
@@ -21,16 +21,17 @@ import Control.Monad.Reader
import
Control.Monad.Trans.Control
(
MonadBaseControl
)
import
Data.Aeson
(
Result
(
Error
,
Success
),
fromJSON
,
FromJSON
)
import
Data.ByteString.Char8
(
hPutStrLn
)
import
Data.Either.Extra
(
Either
(
Left
,
Right
))
import
Data.Ini
(
readIniFile
,
lookupValue
)
import
Data.Either.Extra
(
Either
)
import
Data.Pool
(
Pool
,
withResource
)
import
Data.Profunctor.Product.Default
(
Default
)
import
Data.Text
(
unpack
,
pack
,
Text
)
import
Data.Text
(
unpack
,
Text
)
import
Data.Word
(
Word16
)
import
Database.PostgreSQL.Simple
(
Connection
,
connect
)
import
Database.PostgreSQL.Simple.FromField
(
Conversion
,
ResultError
(
ConversionFailed
),
fromField
,
returnError
)
import
Database.PostgreSQL.Simple.Internal
(
Field
)
import
Gargantext.Core.Mail.Types
(
HasMail
)
import
Gargantext.Prelude
import
Gargantext.Prelude.Config
(
readIniFile'
,
val
)
import
Opaleye
(
Query
,
Unpackspec
,
showSql
,
FromFields
,
Select
,
runSelect
,
PGJsonb
,
DefaultFromField
)
import
Opaleye.Aggregate
(
countRows
)
import
System.IO
(
FilePath
)
...
...
@@ -77,13 +78,15 @@ type CmdM env err m =
(
CmdM'
env
err
m
,
HasConnectionPool
env
,
HasConfig
env
,
HasMail
env
)
type
CmdRandom
env
err
m
=
(
CmdM'
env
err
m
,
HasConnectionPool
env
,
HasConfig
env
,
MonadRandom
m
,
MonadRandom
m
,
HasMail
env
)
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
databaseParameters
::
FilePath
->
IO
PGS
.
ConnectInfo
databaseParameters
fp
=
do
ini
<-
readIniFile
fp
let
ini''
=
case
ini
of
Left
e
->
panic
(
pack
$
"No ini file error"
<>
show
e
)
Right
ini'
->
ini'
let
val
x
=
case
(
lookupValue
(
pack
"database"
)
(
pack
x
)
ini''
)
of
Left
_
->
panic
(
pack
$
"no"
<>
x
)
Right
p'
->
unpack
p'
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"
ini
<-
readIniFile'
fp
let
val'
key
=
unpack
$
val
ini
"database"
key
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
...
...
stack.yaml
View file @
0c237cda
...
...
@@ -27,9 +27,8 @@ allow-newer: true
# "$everything": -haddock
extra-deps
:
-
#git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
git
:
https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude.git
commit
:
35b09629a658fc16cc9ff63e7591e58511cd98a7
-
git
:
https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
commit
:
6bfdb29e9a576472c7fd7ebe648ad101e5b3927f
# Data Mining Libs
-
git
:
https://github.com/delanoe/data-time-segment.git
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