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