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

gargantext.ini_toModify

@@ -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

@@ -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

@@ -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

src/Gargantext/API/Admin/Settings.hs

@@ -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

@@ -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_mail      = mail
         }
 
 -- | Run Cmd Sugar for the Repl (GHCI)

src/Gargantext/API/Ngrams.hs

@@ -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')
@@ -348,6 +349,7 @@ tableNgramsPull listId ngramsType p_version = do
 tableNgramsPut :: ( HasNodeStory env err m
                   , 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

src/Gargantext/API/Prelude.hs

@@ -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(..))
@@ -55,6 +56,7 @@ type EnvC env =
   , HasJobEnv         env JobLog JobLog
   , HasConfig         env
   , HasNodeStoryEnv   env
+  , HasMail           env
   )
 
 type ErrC err =

src/Gargantext/Core/Mail.hs

@@ -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

+{-|
+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

@@ -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

src/Gargantext/Database/Action/Mail.hs

@@ -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
+  liftBase $ mail cfg (MailInfo { mailInfo_username = userLight_username userLight
                                 , mailInfo_address = userLight_email userLight })
 

src/Gargantext/Database/Action/Metrics.hs

@@ -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)

src/Gargantext/Database/Action/User/New.hs

@@ -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

@@ -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,6 +78,7 @@ type CmdM env err m =
   ( CmdM'             env err m
   , HasConnectionPool env
   , HasConfig         env
+  , HasMail           env
   )
 
 type CmdRandom env err m =
@@ -84,6 +86,7 @@ type CmdRandom env err m =
   , HasConnectionPool env
   , HasConfig         env
   , 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

@@ -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