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
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
......@@ -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
......
......@@ -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 ''DevEnv
......@@ -118,4 +125,5 @@ instance HasRepoSaver DevEnv where
instance HasRepo DevEnv where
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
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)
......
......@@ -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)
......
......@@ -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 '[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
-> 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
......
......@@ -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 =
......
......@@ -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
......
{-|
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, (^.))
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 :: (HasMail env, HasConfig env, HasConnectionPool env, HasNodeError err)
=> User
-> NodeId
-> Cmd' env err Int
......
......@@ -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 })
......@@ -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 :: (HasMail env, HasNodeStory env err m)
=> CorpusId -> Maybe ListId -> TabType
-> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
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