Commit 0c237cda authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski

[mail] add HasMail class, use gargantext.ini for config

parent 797e19df
Pipeline #2067 failed with stage
in 10 minutes and 14 seconds
...@@ -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
...@@ -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
......
...@@ -17,10 +17,12 @@ import qualified Servant.Job.Core ...@@ -17,10 +17,12 @@ import qualified Servant.Job.Core
import Gargantext.API.Ngrams.Types (HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..)) 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
...@@ -32,6 +34,7 @@ data Env = Env ...@@ -32,6 +34,7 @@ data Env = Env
, _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,6 +58,9 @@ instance HasNodeStorySaver Env where ...@@ -55,6 +58,9 @@ instance HasNodeStorySaver Env where
instance HasSettings Env where instance HasSettings Env where
settings = env_settings settings = env_settings
instance HasMail Env where
mailSettings = env_mail
-- Specific to Repo -- Specific to Repo
instance HasRepoVar Env where instance HasRepoVar Env where
repoVar = repoEnv . repoVar repoVar = repoEnv . repoVar
...@@ -87,6 +93,7 @@ data DevEnv = DevEnv ...@@ -87,6 +93,7 @@ data DevEnv = DevEnv
, _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 ''DevEnv makeLenses ''DevEnv
...@@ -118,4 +125,5 @@ instance HasRepoSaver DevEnv where ...@@ -118,4 +125,5 @@ instance HasRepoSaver DevEnv where
instance HasRepo DevEnv where instance HasRepo DevEnv where
repoEnv = dev_env_repo repoEnv = dev_env_repo
instance HasMail DevEnv where
mailSettings = dev_env_mail
...@@ -47,6 +47,7 @@ import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_vers ...@@ -47,6 +47,7 @@ import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_vers
import Gargantext.Database.Prelude (databaseParameters, HasConfig(..)) import Gargantext.Database.Prelude (databaseParameters, HasConfig(..))
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
...@@ -182,6 +183,7 @@ newEnv port file = do ...@@ -182,6 +183,7 @@ newEnv port file = do
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'
...@@ -193,6 +195,7 @@ newEnv port file = do ...@@ -193,6 +195,7 @@ newEnv port file = do
, _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)
......
...@@ -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)
...@@ -41,12 +42,14 @@ withDevEnv iniPath k = do ...@@ -41,12 +42,14 @@ withDevEnv iniPath k = do
pool <- newPool dbParam pool <- newPool dbParam
repo <- readRepoEnv (_gc_repofilepath cfg) 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_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)
......
...@@ -102,6 +102,7 @@ import Gargantext.API.Job ...@@ -102,6 +102,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 +281,7 @@ newNgramsFromNgramsStatePatch p = ...@@ -280,7 +281,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 +347,9 @@ tableNgramsPull listId ngramsType p_version = do ...@@ -346,8 +347,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 +496,7 @@ type MaxSize = Int ...@@ -494,7 +496,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 +619,7 @@ getTableNgrams _nType nId tabType listId limit_ offset ...@@ -617,7 +619,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 +714,7 @@ type TableNgramsAsyncApi = Summary "Table Ngrams Async API" ...@@ -712,7 +714,7 @@ type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
:> "update" :> "update"
:> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog :> AsyncJobs JobLog '[JSON] 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 +748,7 @@ getTableNgramsVersion _nId _tabType listId = currentVersion listId ...@@ -746,7 +748,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
......
...@@ -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 =
......
...@@ -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
......
{-|
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
...@@ -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 :: (HasMail env, HasConfig env, HasConnectionPool env, HasNodeError err)
=> User => User
-> NodeId -> NodeId
-> Cmd' env err Int -> Cmd' env err Int
......
...@@ -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 })
...@@ -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 :: (HasMail env, HasNodeStory 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)
......
...@@ -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
......
...@@ -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
......
...@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment