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 m (Just u) subject body)
  52
  53 ------------------------------------------------------------------------
  54 emailWith :: ServerAddress -> MailModel -> Text
  55 emailWith server model =
  56   unlines $ [ "Hello" ]
  57           <> bodyWith server model
  58           <> email_disclaimer
  59           <> email_signature
  60
  61 ------------------------------------------------------------------------
  62 email_to :: MailModel -> (EmailAddress, Name)
  63 email_to (Invitation user) = email_to' user
  64 email_to (PassUpdate user) = email_to' user
  65 email_to (MailInfo { .. })    = (mailInfo_address, mailInfo_username)
  66
  67 email_to' :: NewUser GargPassword -> (EmailAddress, Name)
  68 email_to' (NewUser u m _) = (m,u)
  69
  70 ------------------------------------------------------------------------
  71 bodyWith :: ServerAddress -> MailModel -> [Text]
  72 bodyWith server (Invitation u) = [ "Congratulation, you have been granted a user account to test the"
  73                                  , "new GarganText platform!"
  74                                  ] <> (email_credentials server u)
  75
  76 bodyWith server (PassUpdate u) = [ "Your account password have been updated on the GarganText platform!"
  77                                  ] <> (email_credentials server u)
  78
  79 bodyWith server (MailInfo _ _) = [ "Your last analysis is over on the server: " <> server]
  80
  81 ------------------------------------------------------------------------
  82 email_subject :: MailModel -> Text
  83 email_subject (Invitation _) = "[GarganText] Invitation"
  84 email_subject (PassUpdate _) = "[GarganText] Update"
  85 email_subject (MailInfo _ _) = "[GarganText] Info"
  86
  87
  88 email_credentials :: ServerAddress -> NewUser GargPassword -> [Text]
  89 email_credentials server (NewUser u _ (GargPassword p)) =
  90           [ ""
  91           , "You can log in to: " <> server
  92           , "Your username is: "  <> u
  93           , "Your password is: "  <> p
  94           , ""
  95           ]
  96
  97 email_disclaimer :: [Text]
  98 email_disclaimer =
  99             [ ""
 100             , "If you log in you agree with the following terms of use:"
 101             , "          https://gitlab.iscpif.fr/humanities/tofu/tree/master"
 102             , ""
 103             , ""
 104             , "/!\\ Please note that your account is opened for beta tester only. Hence"
 105             , "we cannot guarantee neither the perenniality nor the stability of the"
 106             , "service at this stage. It is therefore advisable to back up important"
 107             , "data regularly."
 108             , ""
 109             , "/!\\ Gargantext is an academic service supported by ISC-PIF partners."
 110             , "In case of congestion on this service, access to members of the ISC-PIF"
 111             , "partners will be privileged."
 112             , ""
 113             , "Your feedback will be valuable for further development of the platform,"
 114             , "do not hesitate to contact us and to contribute on our forum:"
 115             , ""
 116             , "     https://discourse.iscpif.fr/c/gargantext"
 117             , ""
 118             ]
 119
 120 email_signature :: [Text]
 121 email_signature =
 122           [ "With our best regards,"
 123           , "-- "
 124           , "The Gargantext Team (CNRS)"
 125           ]
 126