Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 210 lines (190 sloc) 8.179 kb
fccc685 Initial open-source release
MLstate authored
1 % -*-erlang-*-
2
3 %
32e2e4d @Aqua-Ye [enhance] bslMail: switched the smtpServer into CPS
Aqua-Ye authored
4 % Copyright © 2011, 2012 MLstate
fccc685 Initial open-source release
MLstate authored
5 %
6fac5ce @Aqua-Ye [cleanup] ocamllib: typo on Opa
Aqua-Ye authored
6 % This file is part of Opa.
fccc685 Initial open-source release
MLstate authored
7 %
6fac5ce @Aqua-Ye [cleanup] ocamllib: typo on Opa
Aqua-Ye authored
8 % Opa is free software: you can redistribute it and/or modify it under the
fccc685 Initial open-source release
MLstate authored
9 % terms of the GNU Affero General Public License, version 3, as published by
10 % the Free Software Foundation.
11 %
6fac5ce @Aqua-Ye [cleanup] ocamllib: typo on Opa
Aqua-Ye authored
12 % Opa is distributed in the hope that it will be useful, but WITHOUT ANY
fccc685 Initial open-source release
MLstate authored
13 % WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
14 % FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
15 % more details.
16 %
17 % You should have received a copy of the GNU Affero General Public License
6fac5ce @Aqua-Ye [cleanup] ocamllib: typo on Opa
Aqua-Ye authored
18 % along with Opa. If not, see <http://www.gnu.org/licenses/>.
fccc685 Initial open-source release
MLstate authored
19 %
20 -generate server
21 -debugvar PROTOCOL_DEBUG
22 -protocol SMTP
23
24 -open Printf
25 -open Rcontent
26
27 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
28 %% Les types %%
29 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
30 -type email = { from : string ; dests : string list ; body : content }
31
32 -type state = {
33 server_domain: string;
34 server_port: int;
35 hello_message: string;
36 client_domain: string;
32e2e4d @Aqua-Ye [enhance] bslMail: switched the smtpServer into CPS
Aqua-Ye authored
37 callback: email -> ((int * string) -> unit) -> unit;
fccc685 Initial open-source release
MLstate authored
38 verify: string -> int * string;
39 expand: string -> (int * string) list;
40 extended: bool
41 }
42
43 -type payload = unit
8d13b87 @Aqua-Ye [fix] compilation: wip compilation fix
Aqua-Ye authored
44 -include "ocamllib/libnet/rt_proto.proto"
fccc685 Initial open-source release
MLstate authored
45
46 -type runtime = {
47 rt_plim : int;
48 rt_dialog_name : string;
49 rt_on_close : Scheduler.t -> unit;
50 rt_proto : rt_proto;
51 }
52
53 {{
54 let rec msglst = function
55 | [] -> []
56 | [(c,s)] -> [Ns (c,s)]
57 | ((c,s)::rest) -> (ENs (c,s))::(msglst rest)
58 }}
59
faf1ba9 @nrs135 [fix] libnet: Fixed dot stuffing for smtpServer.
nrs135 authored
60 [[
61 let unstuff(last_was_crlf, str) =
62 let str =
63 if last_was_crlf && String.length(str) >= 2 && str.[0] = '.' && str.[1] = '.'
64 then String.sub str 1 (String.length(str) - 1)
65 else str
66 in
67 String.replace str "\r\n.." "\r\n.";;
68 ]]
69
fccc685 Initial open-source release
MLstate authored
70 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
71 %% Messages envoyés/reçus %%
72 %% Different structure between server and client %%
73 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
74 -define (Ehlo host) = "EHLO "~ host "\r\n"
75 -define (Helo host) = "HELO "~ host "\r\n"
76 -define (From str) = "MAIL FROM:<"~ str ">\r\n"
77 -define (To str) = "RCPT TO:<"~ str ">\r\n"
78 -define Data = "DATA\r\n"~
79 -define Dot = ".\r\n"
80 -define DotDot = "..\r\n"
81 -define Crlf = "\r\n"
82 -define (Vrfy str) = "VRFY "~ str "\r\n"
83 -define (Expn str) = "EXPN "~ str "\r\n"
84 -define Noop = "NOOP\r\n"~
85 -define Rset = "RSET\r\n"~
86 -define Quit = "QUIT\r\n"~
87 -define (ENs (num : int, str)) = num "-" str "\r\n"
88 -define (Ns (num : int, str)) = num " " str "\r\n"
89 -define (RawInput str) = !".\r\n" !"..\r\n" str
90
91 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
92 %% L'automate %%
93 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
94 +on_connection(state : state):
95 {{ eprintf "on_connection\n"; Pervasives.flush stderr }}
96 let str = {{ sprintf "%s %s" state.server_domain state.hello_message }}
97 send(Ns (220,str));
98 wait_for_hello(state)
99
100 wait_for_hello(state : state):
101 receive
102 | Ehlo domain -> send_greeting({{ { state with client_domain = domain; extended = true } }})
103 | Helo domain -> send_greeting({{ { state with client_domain = domain; extended = false } }})
104 | Vrfy str -> let resp = {{ state.verify str }} send(Ns resp); wait_for_hello(state)
105 | Expn str -> let resp = {{ msglst (state.expand str) }} send_all(resp); wait_for_hello(state)
106 | Noop -> send(Ns(250,"Ok")); wait_for_hello(state)
107 | Rset -> send(Ns(250,"Ok")); wait_for_hello(state)
108 | Quit -> send(Ns(221,"Bye")); -!-
109 | RawInput _ -> send(Ns(500,"Command not recognised")); wait_for_hello(state)
110 | _ -> send(Ns(502,"Command not implemented")); wait_for_hello(state)
111 catch
112 | exn -> error({{ sprintf "wait_for_hello: exn=%s" (Printexc.to_string exn) }}, state)
113
114 send_greeting(state : state):
115 let str = {{ sprintf "Hello %s" state.client_domain }}
116 send(Ns (250,str));
117 wait_for_message(state, {{ { from=""; dests=[]; body=ContentNone } }})
118
119 wait_for_message(state : state, email : email):
120 receive
121 | From sender ->
122 if {{ email.from <> "" }}
123 then
124 send(Ns(503,"Bad sequence of commands"));
125 wait_for_message(state, email)
126 else
127 let email = {{ { email with from = sender } }}
128 send(Ns (250,"Ok"));
129 wait_for_message(state, email)
130 | To recipient ->
131 let email = {{ { email with dests = recipient::email.dests } }}
132 send(Ns (250,"Ok"));
133 wait_for_message(state, email)
134 | Data ->
135 send(Ns (354,"End data with <CR><LF>.<CR><LF>"));
136 get_data(state, email, false)
137 | Vrfy str -> let resp = {{ state.verify str }} send(Ns resp); wait_for_message(state,email)
138 | Expn str -> let resp = {{ msglst (state.expand str) }} send_all(resp); wait_for_message(state,email)
139 | Noop -> send(Ns(250,"Ok")); wait_for_message(state,email)
140 | Rset -> send(Ns(250,"Ok")); wait_for_hello(state)
141 | Quit -> send(Ns(221,"Bye")); -!-
142 | RawInput _ -> send(Ns(500,"Command not recognised")); wait_for_hello(state)
143 | _ -> send(Ns(502,"Command not implemented")); wait_for_hello(state)
144 catch
145 | exn -> error({{ sprintf "exn: %s" (Printexc.to_string exn) }}, state)
146
147 get_data(state : state, email : email, last_was_crlf : bool):
148 %% upto data = "\r\n.\r\n";
149 %% debug {{ eprintf "data='%s'\n" (String.escaped data) }}
150 %% let email = {{ { email with body = content_add (data^"\r\n") email.body } }}
151 %% process_email(state, email)
152 receive
153 | RawInput str ->
faf1ba9 @nrs135 [fix] libnet: Fixed dot stuffing for smtpServer.
nrs135 authored
154 let str = {{ unstuff(last_was_crlf,str) }}
fccc685 Initial open-source release
MLstate authored
155 debug {{ eprintf "get_data: RawInput='%s'\n" (String.escaped str); Pervasives.flush stderr }}
156 let email = {{ { email with body = content_add str email.body } }}
157 get_data(state, email, {{ String.is_suffix "\r\n" str }})
158 | Crlf ->
159 debug {{ eprintf "get_data: Crlf\n"; Pervasives.flush stderr }}
160 let email = {{ { email with body = content_add "\r\n" email.body } }}
161 get_data(state, email, true)
162 | Dot ->
163 debug {{ eprintf "get_data: Dot last_was_crlf:%b\n" last_was_crlf; Pervasives.flush stderr }}
164 if {{ last_was_crlf }}
165 then process_email(state, email)
166 else
167 let email = {{ { email with body = content_add ".\r\n" email.body } }}
168 get_data(state, email, true)
169 | DotDot ->
170 debug {{ eprintf "get_data: DotDot\n"; Pervasives.flush stderr }}
171 let email = {{ { email with body = content_add ".\r\n" email.body } }}
172 get_data(state, email, true)
173 | Vrfy str -> let resp = {{ state.verify str }} send(Ns resp); get_data(state,email,last_was_crlf)
174 | Expn str -> let resp = {{ msglst (state.expand str) }} send_all(resp); get_data(state,email,last_was_crlf)
175 | Noop -> send(Ns(250,"Ok")); get_data(state,email,last_was_crlf)
176 | Rset -> send(Ns(250,"Ok")); wait_for_hello(state)
177 | Quit -> send(Ns(221,"Bye")); -!-
178 | _ -> send(Ns(502,"Command not implemented")); wait_for_hello(state)
179 catch
180 | exn -> error({{ sprintf "exn: %s" (Printexc.to_string exn) }}, state)
181
32e2e4d @Aqua-Ye [enhance] bslMail: switched the smtpServer into CPS
Aqua-Ye authored
182 send_response(reply, state):
fccc685 Initial open-source release
MLstate authored
183 send(reply);
184 wait_for_quit(state)
185
32e2e4d @Aqua-Ye [enhance] bslMail: switched the smtpServer into CPS
Aqua-Ye authored
186 process_email(state:state, email:email):
187 debug {{ eprintf "process_email\n"; Pervasives.flush stderr }}
188 let cpl = !"state.callback" << state.callback email >>
189 let res = {{ Ns(fst cpl, snd cpl) }}
190 send_response(res, state)
191
fccc685 Initial open-source release
MLstate authored
192 wait_for_quit(state):
193 receive
194 | Vrfy str -> let resp = {{ state.verify str }} send(Ns resp); wait_for_quit(state)
195 | Expn str -> let resp = {{ msglst (state.expand str) }} send_all(resp); wait_for_quit(state)
196 | Noop -> send(Ns(250,"Ok")); wait_for_quit(state)
197 | Rset -> send(Ns(250,"Ok")); wait_for_hello(state)
198 | Quit -> send(Ns(221,"Bye")); -!-
199 | RawInput _ -> send(Ns(500,"Command not recognised")); wait_for_hello(state)
200 | _ -> send(Ns(502,"Command not implemented")); wait_for_hello(state)
201 catch
202 | exn -> error({{ sprintf "exn: %s" (Printexc.to_string exn) }}, state)
203
204 error(msg : string, _state : state):
205 send(Ns(451,"Server error"));
206 debug {{ eprintf "error %s\n" msg; Pervasives.flush stderr }}
207 {{ Logger.error "Error: %s" msg }}
208 -!-
209
Something went wrong with that request. Please try again.