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, gc_backend_name)
  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 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 mail :: (CmdM env err m) => MailConfig -> MailModel -> m ()
  50 mail mailCfg model = do
  51   cfg <- view hasConfig
  52   let
  53     (m,u)   = email_to         model
  54     subject = email_subject    model
  55     body    = emailWith (ServerAddress (view gc_backend_name cfg) (view gc_url cfg)) model
  56   liftBase $ gargMail mailCfg (GargMail { gm_to = m
  57                                         , gm_name = Just u
  58                                         , gm_subject = subject
  59                                         , gm_body = body })
  60
  61 ------------------------------------------------------------------------
  62 emailWith :: ServerAddress -> MailModel -> Text
  63 emailWith server model =
  64   unlines $ [ "Hello" ]
  65           <> bodyWith server model
  66           <> email_disclaimer
  67           <> email_signature
  68
  69 ------------------------------------------------------------------------
  70 email_to :: MailModel -> (EmailAddress, Name)
  71 email_to (Invitation user) = email_to' user
  72 email_to (PassUpdate user) = email_to' user
  73 email_to (MailInfo { .. })    = (mailInfo_address, mailInfo_username)
  74 email_to (ForgotPassword { user = UserLight { .. }}) = (userLight_email, userLight_username)
  75
  76 email_to' :: NewUser GargPassword -> (EmailAddress, Name)
  77 email_to' (NewUser u m _) = (m,u)
  78
  79 ------------------------------------------------------------------------
  80 bodyWith :: ServerAddress -> MailModel -> [Text]
  81 bodyWith server@(ServerAddress name _url) (Invitation u) = [ "Congratulation, you have been granted a user account to test the"
  82                                  , "new GarganText platform called " <> name <> " !"
  83                                  ] <> (email_credentials server u)
  84
  85 bodyWith server (PassUpdate u) = [ "Your account password have been updated on the GarganText platform!"
  86                                  ] <> (email_credentials server u)
  87
  88 bodyWith (ServerAddress _ url) (MailInfo _ _) = [ "Your last analysis is over on the server: " <> url]
  89 bodyWith _server (ForgotPassword { user = UserLight { userLight_forgot_password_uuid = Nothing }}) =
  90   [ "Cannot send you link to forgot password, no UUID" ]
  91 bodyWith server (ForgotPassword { user = UserLight { userLight_forgot_password_uuid = Just uuid }}) =
  92   [ "Click on this link to restore your password: "
  93   , forgot_password_link server uuid ]
  94
  95 forgot_password_link :: ServerAddress -> Text -> Text
  96 forgot_password_link (ServerAddress _ server) uuid = server <> "/#/forgotPassword?uuid=" <> uuid <> "&server=" <> encodeText server
  97
  98 ------------------------------------------------------------------------
  99 email_subject :: MailModel -> Text
 100 email_subject (Invitation _)     = "[GarganText] Invitation"
 101 email_subject (PassUpdate _)     = "[GarganText] Update"
 102 email_subject (MailInfo _ _)     = "[GarganText] Info"
 103 email_subject (ForgotPassword _) = "[GarganText] Forgot Password"
 104
 105
 106 email_credentials :: ServerAddress -> NewUser GargPassword -> [Text]
 107 email_credentials (ServerAddress _ server) (NewUser u _ (GargPassword p)) =
 108           [ ""
 109           , "You can log in to: " <> server
 110           , "Your username is: "  <> u
 111           , "Your password is: "  <> p
 112           , ""
 113           ]
 114
 115 email_disclaimer :: [Text]
 116 email_disclaimer =
 117             [ ""
 118             , "/!\\ Please note that your account is opened for beta tester only. Hence"
 119             , "we cannot guarantee neither the perenniality nor the stability of the"
 120             , "service at this stage. It is therefore advisable to back up important"
 121             , "data regularly."
 122             , ""
 123             , "/!\\ Gargantext is an academic service supported by CNRS/ISC-PIF partners."
 124             , "In case of congestion on this service, access to members of the ISC-PIF"
 125             , "partners will be privileged."
 126             , ""
 127             , "If you log in you agree with the following terms of use:"
 128             , "     https://gitlab.iscpif.fr/humanities/tofu/tree/master"
 129             , ""
 130             , "Your feedback will be valuable for further development of the platform,"
 131             , "do not hesitate to contact us and to contribute on our forum:"
 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