src/Gargantext/Core/Mail.hs

   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 Network.URI.Encode (encodeText)
  16 import Data.Text (Text, unlines, splitOn)
  17 import Gargantext.Core.Types.Individu
  18 import Gargantext.Database.Schema.User (UserLight(..))
  19 import Gargantext.Prelude
  20 import Gargantext.Prelude.Config (gc_url)
  21 import Gargantext.Database.Prelude
  22 -- import Gargantext.Prelude.Config (gc_url)
  23 import Gargantext.Prelude.Mail (gargMail, GargMail(..))
  24 import Gargantext.Prelude.Mail.Types (MailConfig)
  25 import qualified Data.List as List
  26
  27
  28 -- | Tool to put elsewhere
  29 isEmail :: Text -> Bool
  30 isEmail = ((==) 2) . List.length . (splitOn "@")
  31
  32 ------------------------------------------------------------------------
  33 data SendEmail    = SendEmail Bool
  34
  35 type EmailAddress  = Text
  36 type Name          = Text
  37 type ServerAddress = Text
  38
  39 data MailModel = Invitation { invitation_user :: NewUser GargPassword }
  40                | PassUpdate { passUpdate_user :: NewUser GargPassword }
  41                | MailInfo   { mailInfo_username :: Name
  42                             , mailInfo_address  :: EmailAddress
  43                             }
  44                | ForgotPassword { user :: UserLight }
  45 ------------------------------------------------------------------------
  46 ------------------------------------------------------------------------
  47 mail :: (CmdM env err m) => MailConfig -> MailModel -> m ()
  48 mail mailCfg model = do
  49   cfg <- view hasConfig
  50   let
  51     (m,u)   = email_to         model
  52     subject = email_subject    model
  53     body    = emailWith (view gc_url cfg)    model
  54   liftBase $ gargMail mailCfg (GargMail { gm_to = m
  55                                         , gm_name = Just u
  56                                         , gm_subject = subject
  57                                         , gm_body = body })
  58
  59 ------------------------------------------------------------------------
  60 emailWith :: ServerAddress -> MailModel -> Text
  61 emailWith server model =
  62   unlines $ [ "Hello" ]
  63           <> bodyWith server model
  64           <> email_disclaimer
  65           <> email_signature
  66
  67 ------------------------------------------------------------------------
  68 email_to :: MailModel -> (EmailAddress, Name)
  69 email_to (Invitation user) = email_to' user
  70 email_to (PassUpdate user) = email_to' user
  71 email_to (MailInfo { .. })    = (mailInfo_address, mailInfo_username)
  72 email_to (ForgotPassword { user = UserLight { .. }}) = (userLight_email, userLight_username)
  73
  74 email_to' :: NewUser GargPassword -> (EmailAddress, Name)
  75 email_to' (NewUser u m _) = (m,u)
  76
  77 ------------------------------------------------------------------------
  78 bodyWith :: ServerAddress -> MailModel -> [Text]
  79 bodyWith server (Invitation u) = [ "Congratulation, you have been granted a user account to test the"
  80                                  , "new GarganText platform!"
  81                                  ] <> (email_credentials server u)
  82
  83 bodyWith server (PassUpdate u) = [ "Your account password have been updated on the GarganText platform!"
  84                                  ] <> (email_credentials server u)
  85
  86 bodyWith server (MailInfo _ _) = [ "Your last analysis is over on the server: " <> server]
  87 bodyWith _server (ForgotPassword { user = UserLight { userLight_forgot_password_uuid = Nothing }}) =
  88   [ "Cannot send you link to forgot password, no UUID" ]
  89 bodyWith server (ForgotPassword { user = UserLight { userLight_forgot_password_uuid = Just uuid }}) =
  90   [ "Click on this link to restore your password: "
  91   , forgot_password_link server uuid ]
  92
  93 forgot_password_link :: ServerAddress -> Text -> Text
  94 forgot_password_link server uuid = server <> "/#/forgotPassword?uuid=" <> uuid <> "&server=" <> encodeText server
  95
  96 ------------------------------------------------------------------------
  97 email_subject :: MailModel -> Text
  98 email_subject (Invitation _)     = "[GarganText] Invitation"
  99 email_subject (PassUpdate _)     = "[GarganText] Update"
 100 email_subject (MailInfo _ _)     = "[GarganText] Info"
 101 email_subject (ForgotPassword _) = "[GarganText] Forgot Password"
 102
 103
 104 email_credentials :: ServerAddress -> NewUser GargPassword -> [Text]
 105 email_credentials server (NewUser u _ (GargPassword p)) =
 106           [ ""
 107           , "You can log in to: " <> server
 108           , "Your username is: "  <> u
 109           , "Your password is: "  <> p
 110           , ""
 111           ]
 112
 113 email_disclaimer :: [Text]
 114 email_disclaimer =
 115             [ ""
 116             , "If you log in you agree with the following terms of use:"
 117             , "          https://gitlab.iscpif.fr/humanities/tofu/tree/master"
 118             , ""
 119             , ""
 120             , "/!\\ Please note that your account is opened for beta tester only. Hence"
 121             , "we cannot guarantee neither the perenniality nor the stability of the"
 122             , "service at this stage. It is therefore advisable to back up important"
 123             , "data regularly."
 124             , ""
 125             , "/!\\ Gargantext is an academic service supported by ISC-PIF partners."
 126             , "In case of congestion on this service, access to members of the ISC-PIF"
 127             , "partners will be privileged."
 128             , ""
 129             , "Your feedback will be valuable for further development of the platform,"
 130             , "do not hesitate to contact us and to contribute on our forum:"
 131             , ""
 132             , "     https://discourse.iscpif.fr/c/gargantext"
 133             , ""
 134             ]
 135
 136 email_signature :: [Text]
 137 email_signature =
 138           [ "With our best regards,"
 139           , "-- "
 140           , "The Gargantext Team (CNRS)"
 141           ]
 142