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