[FEAT] SendMails workflow + refactor

src/Gargantext/API/Admin/EnvTypes.hs

@@ -37,7 +37,7 @@ data Env = Env
 makeLenses ''Env
 
 instance HasConfig Env where
-  config = env_config
+  hasConfig = env_config
 
 instance HasConnectionPool Env where
   connPool = env_pool
@@ -78,7 +78,7 @@ data DevEnv = DevEnv
 makeLenses ''DevEnv
 
 instance HasConfig DevEnv where
-  config = dev_env_config
+  hasConfig = dev_env_config
 
 instance HasConnectionPool DevEnv where
   connPool = dev_env_pool
@@ -93,4 +93,4 @@ instance HasRepo DevEnv where
   repoEnv = dev_env_repo
 
 instance HasSettings DevEnv where
-  settings = dev_env_settings
+  settings = dev_env_settings
\ No newline at end of file

src/Gargantext/API/Admin/Settings.hs

@@ -191,7 +191,7 @@ newPool param = createPool (connect param) close 1 (60*60) 8
 cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
 cleanEnv env = do
   r <- takeMVar (env ^. repoEnv . renv_var)
-  repoSaverAction (env ^. config . gc_repofilepath) r
+  repoSaverAction (env ^. hasConfig . gc_repofilepath) r
   unlockFile (env ^. repoEnv . renv_lock)
 
 type IniPath  = FilePath

src/Gargantext/API/Node/Corpus/New.hs

@@ -41,6 +41,7 @@ import Gargantext.API.Admin.Types (HasSettings)
 import Gargantext.API.Node.Corpus.New.File
 import Gargantext.API.Node.Types
 import Gargantext.Core (Lang(..){-, allLangs-})
+import Gargantext.Database.Action.Mail (sendMail)
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Database.Action.Flow (FlowCmdM, flowCorpus, getDataText, flowDataText, TermType(..), DataOrigin(..){-, allDataOrigins-})
@@ -187,7 +188,7 @@ addToCorpusWithQuery :: FlowCmdM env err m
                        -> Maybe Integer
                        -> (JobLog -> m ())
                        -> m JobLog
-addToCorpusWithQuery u cid (WithQuery q dbs l _nid) maybeLimit logStatus = do
+addToCorpusWithQuery user cid (WithQuery q dbs l _nid) maybeLimit logStatus = do
   -- TODO ...
   logStatus JobLog { _scst_succeeded = Just 0
                    , _scst_failed    = Just 0
@@ -207,8 +208,10 @@ addToCorpusWithQuery u cid (WithQuery q dbs l _nid) maybeLimit logStatus = do
                    , _scst_events    = Just []
                    }
 
-  cids <- mapM (\txt -> flowDataText u txt (Multi l) cid) txts
+  cids <- mapM (\txt -> flowDataText user txt (Multi l) cid) txts
   printDebug "corpus id" cids
+  printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
+  sendMail user
   -- TODO ...
   pure      JobLog { _scst_succeeded = Just 3
                    , _scst_failed    = Just 0
@@ -268,6 +271,9 @@ addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus = do
                      (map (map toHyperdataDocument) docs)
 
   printDebug "Extraction finished   : " cid
+  printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
+  sendMail user
+
   pure      JobLog { _scst_succeeded = Just 2
                    , _scst_failed    = Just 0
                    , _scst_remaining = Just 0
@@ -339,6 +345,10 @@ addToCorpusWithFile user cid nwf@(NewWithFile _d _l fName) logStatus = do
     _     -> pure ()
 
   printDebug "[addToCorpusWithFile] File upload to corpus finished: " cid
+
+  printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
+  sendMail user
+
   pure $ JobLog { _scst_succeeded = Just 1
                 , _scst_failed    = Just 0
                 , _scst_remaining = Just 0

src/Gargantext/API/Routes.hs

@@ -251,7 +251,7 @@ addCorpusWithQuery :: User -> GargServer New.AddWithQuery
 addCorpusWithQuery user cid =
   serveJobsAPI $
     JobFunction (\q log' -> do
-      limit <- view $ config . gc_max_docs_scrapers
+      limit <- view $ hasConfig . gc_max_docs_scrapers
       New.addToCorpusWithQuery user cid q (Just limit) (liftBase . log')
       {- let log' x = do
         printDebug "addToCorpusWithQuery" x

src/Gargantext/API/Server.hs

@@ -34,7 +34,7 @@ import Gargantext.API.Swagger (swaggerDoc)
 import Gargantext.API.ThrowAll (serverPrivateGargAPI)
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (gc_url_backend_api)
-import Gargantext.Database.Prelude (config)
+import Gargantext.Database.Prelude (hasConfig)
 
 
 serverGargAPI :: Text -> GargServerM env err GargAPI
@@ -58,7 +58,7 @@ server env = do
             (Proxy :: Proxy GargAPI)
             (Proxy :: Proxy AuthContext)
             transform
-            (serverGargAPI (env ^. config . gc_url_backend_api))
+            (serverGargAPI (env ^. hasConfig . gc_url_backend_api))
      :<|> frontEndServer
   where
     transform :: forall a. GargM env GargError a -> Handler a
@@ -67,4 +67,4 @@ server env = do
 
 showAsServantErr :: GargError -> ServerError
 showAsServantErr (GargServerError err) = err
-showAsServantErr a = err500 { errBody = BL8.pack $ show a }
+showAsServantErr a = err500 { errBody = BL8.pack $ show a }
\ No newline at end of file

src/Gargantext/Core/Mail.hs

@@ -20,53 +20,83 @@ import Gargantext.Prelude
 import Gargantext.Prelude.Mail (gargMail, GargMail(..))
 import qualified Data.List as List
 
+-- | Tool to put elsewhere
+isEmail :: Text -> Bool
+isEmail = ((==) 2) . List.length . (splitOn "@")
+
 ------------------------------------------------------------------------
 data SendEmail    = SendEmail Bool
 
 type EmailAddress = Text
+type Name         = Text
 type ServerAdress = Text
-data MailModel = Invitation
-               | Update
 
+data MailModel = Invitation { invitation_user :: NewUser GargPassword }
+               | PassUpdate { passUpdate_user :: NewUser GargPassword }
+               | MailInfo   { mailInfo_username :: Name
+                            , mailInfo_address  :: EmailAddress
+                            }
 ------------------------------------------------------------------------
-isEmail :: Text -> Bool
-isEmail = ((==) 2) . List.length . (splitOn "@")
 ------------------------------------------------------------------------
-
-mail :: ServerAdress -> MailModel -> NewUser GargPassword -> IO ()
-mail server model user@(NewUser u m _) = gargMail (GargMail m (Just u) subject body)
+mail :: ServerAdress -> MailModel -> IO ()
+mail server model = gargMail (GargMail m (Just u) subject body)
   where
-    subject = "[Your Garg Account]"
-    body    = emailWith server model user
+    (m,u)   = email_to         model
+    subject = email_subject    model
+    body    = emailWith server model
+
+------------------------------------------------------------------------
+emailWith :: ServerAdress -> MailModel -> Text
+emailWith server model =
+  unlines $ [ "Hello" ]
+          <> bodyWith server model
+          <> email_disclaimer
+          <> email_signature
+
+------------------------------------------------------------------------
+email_to :: MailModel -> (EmailAddress, Name)
+email_to (Invitation user) = email_to' user
+email_to (PassUpdate user) = email_to' user
+email_to (MailInfo n m)    = (m, n)
+
+email_to' :: NewUser GargPassword -> (EmailAddress, Name)
+email_to' (NewUser u m _) = (u,m)
+
+------------------------------------------------------------------------
+bodyWith :: ServerAdress -> MailModel -> [Text]
+bodyWith server (Invitation u) = [ "Congratulation, you have been granted a beta user account to test the"
+                                 , "new GarganText platform!"
+                                 ] <> (email_credentials server u)
+
+bodyWith server (PassUpdate u) = [ "Your account password have been updated on the GarganText platform!"
+                                 ] <> (email_credentials server u)
 
+bodyWith server (MailInfo _ _) = [ "Your last analysis is over on the server: " <> server]
 
-emailWith :: ServerAdress -> MailModel -> NewUser GargPassword -> Text
-emailWith server model (NewUser u _ (GargPassword p)) = unlines $
-          [ "Hello" ]
-          <> bodyWith model <>
+------------------------------------------------------------------------
+email_subject :: MailModel -> Text
+email_subject (Invitation _) = "[GarganText] Invitation"
+email_subject (PassUpdate _) = "[GarganText] Update"
+email_subject (MailInfo _ _) = "[GarganText] Info"
+
+
+email_credentials :: ServerAdress -> NewUser GargPassword -> [Text]
+email_credentials server (NewUser u _ (GargPassword p)) =
           [ ""
           , "You can log in to: " <> server
           , "Your username is: "  <> u
           , "Your password is: "  <> p
           , ""
           ]
-          <> email_disclaimer
-          <> email_signature
-
-bodyWith :: MailModel -> [Text]
-bodyWith Invitation = [ "Congratulation, you have been granted a beta user account to test the"
-                      , "new GarganText platform!"
-                      ]
-bodyWith Update     = [ "Your account password have been updated on the GarganText platform!"
-                      ]
 
 email_disclaimer :: [Text]
 email_disclaimer =
-            [ "If you log in you agree with the following terms of use:"
+            [ ""
+            , "If you log in you agree with the following terms of use:"
             , "          https://gitlab.iscpif.fr/humanities/tofu/tree/master"
             , ""
             , ""
-            , "/!\\ Please note that this account is opened for beta tester only. Hence"
+            , "/!\\ Please note that your account is opened for beta tester only. Hence"
             , "we cannot guarantee neither the perenniality nor the stability of the"
             , "service at this stage. It is therefore advisable to back up important"
             , "data regularly."

src/Gargantext/Database/Action/Mail.hs

+{-|
+Module      : Gargantext.Database.Action.Mail
+Description : 
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+
+-}
+
+module Gargantext.Database.Action.Mail
+  where
+
+import Control.Lens (view)
+import Gargantext.Prelude
+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(..))
+
+------------------------------------------------------------------------
+
+sendMail :: HasNodeError err => User -> Cmd err ()
+sendMail u = do
+  server <- view $ hasConfig . gc_url
+  userLight <- getUserLightDB u
+  liftBase $ mail server (MailInfo (userLight_username userLight) (userLight_email userLight))
+

src/Gargantext/Database/Action/Node.hs

@@ -100,7 +100,7 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
   case maybeNodeId of
     []  -> nodeError (DoesNotExist i)
     [n] -> do
-      cfg <- view config
+      cfg <- view hasConfig
       u <- case nt of
             NodeFrameWrite -> pure $ _gc_frame_write_url cfg
             NodeFrameCalc  -> pure $ _gc_frame_calc_url  cfg

src/Gargantext/Database/Action/User.hs

@@ -23,6 +23,20 @@ import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Schema.Node
 import Gargantext.Prelude
 
+------------------------------------------------------------------------
+getUserLightWithId :: HasNodeError err => Int -> Cmd err UserLight
+getUserLightWithId i = do
+  candidates <- head <$> getUsersWithId i
+  case candidates of
+    Nothing -> nodeError NoUserFound
+    Just u  -> pure u
+
+getUserLightDB :: HasNodeError err => User -> Cmd err UserLight
+getUserLightDB u = do
+  userId <- getUserId u
+  userLight <- getUserLightWithId userId
+  pure userLight
+
 ------------------------------------------------------------------------
 getUserId :: HasNodeError err
           => User

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

@@ -25,7 +25,6 @@ import Gargantext.Database.Query.Table.User
 import Gargantext.Prelude
 import Gargantext.Prelude.Config
 import Gargantext.Prelude.Crypto.Pass.User (gargPass)
-import qualified Data.List as List
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
@@ -33,7 +32,7 @@ newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err)
          => [EmailAddress] -> m Int64
 newUsers us = do
   us' <- mapM newUserQuick us
-  url <- view $ config . gc_url
+  url <- view $ hasConfig . gc_url
   newUsers' url us'
 ------------------------------------------------------------------------
 newUserQuick :: (MonadRandom m)
@@ -46,9 +45,6 @@ newUserQuick n = do
   pure (NewUser u n (GargPassword pass))
 
 ------------------------------------------------------------------------
-isEmail :: Text -> Bool
-isEmail = ((==) 2) . List.length . (splitOn "@")
-
 guessUserName :: Text -> Maybe (Text,Text)
 guessUserName n = case splitOn "@" n of
     [u',m'] -> if m' /= "" then Just (u',m')
@@ -65,7 +61,7 @@ newUsers' address us = do
   us' <- liftBase         $ mapM toUserHash us
   r   <- insertUsers      $ map toUserWrite us'
   _   <- mapM getOrMkRoot $ map (\u -> UserName (_nu_username u)) us
-  _   <- liftBase         $ mapM (mail address Invitation) us
+  _   <- liftBase         $ mapM (\u -> mail address (Invitation u)) us
   pure r
 ------------------------------------------------------------------------
 
@@ -75,7 +71,7 @@ updateUser (SendEmail send) server u = do
   u' <- liftBase     $ toUserHash   u
   n  <- updateUserDB $ toUserWrite  u'
   _  <- case send of
-     True  -> liftBase     $ mail server Update u
+     True  -> liftBase     $ mail server (PassUpdate u)
      False -> pure ()
   pure n
 

src/Gargantext/Database/Prelude.hs

@@ -51,10 +51,10 @@ instance HasConnectionPool (Pool Connection) where
   connPool = identity
 
 class HasConfig env where
-  config :: Getter env GargConfig
+  hasConfig :: Getter env GargConfig
 
 instance HasConfig GargConfig where
-  config = identity
+  hasConfig = identity
 
 -------------------------------------------------------
 type JSONB = QueryRunnerColumnDefault PGJsonb
@@ -87,10 +87,10 @@ type CmdRandom env err m =
   , MonadRandom             m
   )
 
-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
-type Cmd       err a = forall m env. CmdM   env err m => m a
-type CmdR      err a = forall m env. CmdRandom   env err m => m a
+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
+type Cmd       err a = forall m env. CmdM      env err m => m a
+type CmdR      err a = forall m env. CmdRandom env err m => m a
 
 
 

src/Gargantext/Database/Query/Table/User.hs

@@ -96,6 +96,7 @@ selectUsersLightWith u = proc () -> do
 
 ----------------------------------------------------------
 
+
 getUsersWithId :: Int -> Cmd err [UserLight]
 getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
   where
@@ -139,7 +140,6 @@ usersLight = map toUserLight <$> users
 getUser :: Username -> Cmd err (Maybe UserLight)
 getUser u = userLightWithUsername u <$> usersLight
 
-
 ----------------------------------------------------------------------
 insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
 insertNewUsers newUsers = do

src/Gargantext/Prelude/Utils.hs

@@ -74,7 +74,7 @@ folderFilePath = do
 writeFile :: (MonadReader env m, MonadBase IO m, HasConfig env, SaveFile a)
           => a -> m FilePath
 writeFile a = do
-  dataPath <- view $ config . gc_datafilepath
+  dataPath <- view $ hasConfig . gc_datafilepath
 
   (foldPath, fileName) <- folderFilePath
 
@@ -91,13 +91,13 @@ writeFile a = do
 readFile :: (MonadReader env m, MonadBase IO m, HasConfig env, ReadFile a)
          => FilePath -> m a
 readFile fp = do
-  dataPath <- view $ config . gc_datafilepath
+  dataPath <- view $ hasConfig . gc_datafilepath
   liftBase $ readFile' $ dataPath <> "/" <> fp
 
 removeFile :: (MonadReader env m, MonadBase IO m, HasConfig env)
            => FilePath -> m ()
 removeFile fp = do
-  dataPath <- view $ config . gc_datafilepath
+  dataPath <- view $ hasConfig . gc_datafilepath
   liftBase $ SD.removeFile (dataPath <> "/" <> fp) `catch` handleExists
     where
       handleExists e