1  {-|
  2  Module      : Gargantext.Core.Mail
  3  Description :
  4  Copyright   : (c) CNRS, 2017-Present
  5  License     : AGPL + CECILL v3
  6  Maintainer  : team@gargantext.org
  7  Stability   : experimental
  8  Portability : POSIX
  9  
 10  -}
 11  
 12  module Gargantext.Core.Mail where
 13  
 14  import Control.Lens (view)
 15  import Control.Monad.Trans.Control (MonadBaseControl)
 16  import Data.List qualified as List
 17  import Data.Text (splitOn)
 18  import Gargantext.Core.Types.Individu
 19  import Gargantext.Database.Prelude (HasConfig(..))
 20  import Gargantext.Database.Schema.User (UserLight(..))
 21  import Gargantext.Prelude
 22  import Gargantext.Prelude.Config (gc_url, gc_backend_name)
 23  import Gargantext.Prelude.Mail (gargMail, GargMail(..))
 24  import Gargantext.Prelude.Mail.Types (MailConfig)
 25  import Network.URI.Encode (encodeText)
 26  
 27  
 28  -- | Tool to put elsewhere
 29  isEmail :: Text -> Bool
 30  isEmail = ((==) 2) . List.length . (splitOn "@")
 31  
 32  ------------------------------------------------------------------------
 33  newtype SendEmail = SendEmail Bool
 34  
 35  type EmailAddress  = Text
 36  type Name          = Text
 37  data ServerAddress = ServerAddress { sa_name :: Text
 38                                     , sa_url  :: Text
 39                                     }
 40  
 41  data MailModel = Invitation { invitation_user :: NewUser GargPassword }
 42                 | PassUpdate { passUpdate_user :: NewUser GargPassword }
 43                 | MailInfo   { mailInfo_username :: Name
 44                              , mailInfo_address  :: EmailAddress
 45                              }
 46                 | ForgotPassword { user :: UserLight }
 47  ------------------------------------------------------------------------
 48  
 49  -- | Execute the given input action 'act', sending an email notification
 50  -- only if 'SendEmail' says so.
 51  withNotification :: (MonadBaseControl IO m, HasConfig env, MonadReader env m)
 52                   => SendEmail
 53                   -> MailConfig
 54                   -> (notificationBody -> MailModel)
 55                  -- ^ A function which can build a 'MailModel' out of
 56                  -- the returned type of the action.
 57                   -> m (a, notificationBody)
 58                  -- ^ The action to run. Returns the value @a@ to return
 59                  -- upstream alongside anything needed to build a 'MailModel'.
 60                   -> m a
 61  withNotification (SendEmail doSend) cfg mkNotification act = do
 62    (r, notificationBody) <- act
 63    when doSend $ mail cfg (mkNotification notificationBody)
 64    pure r
 65  
 66  ------------------------------------------------------------------------
 67  mail :: (MonadBaseControl IO m, MonadReader env m, HasConfig env)
 68       => MailConfig
 69       -- ^ The configuration for the email
 70       -> MailModel
 71       -- ^ The notification we want to emit.
 72       -> m ()
 73  mail mailCfg model = do
 74    cfg <- view hasConfig
 75    let
 76      (m,u)   = email_to         model
 77      subject = email_subject    model
 78      body    = emailWith (ServerAddress (view gc_backend_name cfg) (view gc_url cfg)) model
 79    liftBase $ gargMail mailCfg (GargMail { gm_to = m
 80                                          , gm_name = Just u
 81                                          , gm_subject = subject
 82                                          , gm_body = body })
 83  
 84  ------------------------------------------------------------------------
 85  emailWith :: ServerAddress -> MailModel -> Text
 86  emailWith server model =
 87    unlines $ [ "Hello" ]
 88            <> bodyWith server model
 89            <> email_disclaimer
 90            <> email_signature
 91  
 92  ------------------------------------------------------------------------
 93  email_to :: MailModel -> (EmailAddress, Name)
 94  email_to (Invitation user) = email_to' user
 95  email_to (PassUpdate user) = email_to' user
 96  email_to (MailInfo { .. })    = (mailInfo_address, mailInfo_username)
 97  email_to (ForgotPassword { user = UserLight { .. }}) = (userLight_email, userLight_username)
 98  
 99  email_to' :: NewUser GargPassword -> (EmailAddress, Name)
100  email_to' (NewUser u m _) = (m,u)
101  
102  ------------------------------------------------------------------------
103  bodyWith :: ServerAddress -> MailModel -> [Text]
104  bodyWith server@(ServerAddress name _url) (Invitation u) = [ "Congratulation, you have been granted a user account to test the"
105                                   , "new GarganText platform called " <> name <> " !"
106                                   ] <> (email_credentials server u)
107  
108  bodyWith server (PassUpdate u) = [ "Your account password have been updated on the GarganText platform!"
109                                   ] <> (email_credentials server u)
110  
111  bodyWith (ServerAddress _ url) (MailInfo _ _) = [ "Your last analysis is over on the server: " <> url]
112  bodyWith _server (ForgotPassword { user = UserLight { userLight_forgot_password_uuid = Nothing }}) =
113    [ "Cannot send you link to forgot password, no UUID" ]
114  bodyWith server (ForgotPassword { user = UserLight { userLight_forgot_password_uuid = Just uuid }}) =
115    [ "Click on this link to restore your password: "
116    , forgot_password_link server uuid ]
117  
118  forgot_password_link :: ServerAddress -> Text -> Text
119  forgot_password_link (ServerAddress _ server) uuid = server <> "/#/forgotPassword?uuid=" <> uuid <> "&server=" <> encodeText server
120  
121  ------------------------------------------------------------------------
122  email_subject :: MailModel -> Text
123  email_subject (Invitation _)     = "[GarganText] Invitation"
124  email_subject (PassUpdate _)     = "[GarganText] Update"
125  email_subject (MailInfo _ _)     = "[GarganText] Info"
126  email_subject (ForgotPassword _) = "[GarganText] Forgot Password"
127  
128  
129  email_credentials :: ServerAddress -> NewUser GargPassword -> [Text]
130  email_credentials (ServerAddress _ server) (NewUser u _ (GargPassword p)) =
131            [ ""
132            , "You can log in to: " <> server
133            , "Your username is: "  <> u
134            , "Your password is: "  <> p
135            , ""
136            ]
137  
138  email_disclaimer :: [Text]
139  email_disclaimer =
140              [ ""
141              , "/!\\ Please note that your account is opened for beta tester only. Hence"
142              , "we cannot guarantee neither the perenniality nor the stability of the"
143              , "service at this stage. It is therefore advisable to back up important"
144              , "data regularly."
145              , ""
146              , "/!\\ Gargantext is an academic service supported by CNRS/ISC-PIF partners."
147              , "In case of congestion on this service, access to members of the ISC-PIF"
148              , "partners will be privileged."
149              , ""
150              , "If you log in you agree with the following terms of use:"
151              , "     https://gitlab.iscpif.fr/humanities/tofu/tree/master"
152              , ""
153              , "Your feedback will be valuable for further development of the platform,"
154              , "do not hesitate to contact us and to contribute on our forum:"
155              , "     https://discourse.iscpif.fr/c/gargantext"
156              , ""
157              ]
158  
159  email_signature :: [Text]
160  email_signature =
161            [ "With our best regards,"
162            , "-- "
163            , "The Gargantext Team (CNRS)"
164            ]