Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 195 lines (177 sloc) 7.745 kb
fccc685 Initial open-source release
MLstate authored
1 % -*-erlang-*-
2
3 %
4 % Copyright © 2011 MLstate
5 %
6 % This file is part of OPA.
7 %
8 % OPA is free software: you can redistribute it and/or modify it under the
9 % terms of the GNU Affero General Public License, version 3, as published by
10 % the Free Software Foundation.
11 %
12 % OPA is distributed in the hope that it will be useful, but WITHOUT ANY
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
18 % along with OPA. If not, see <http://www.gnu.org/licenses/>.
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;
37 callback: email -> int * string;
38 verify: string -> int * string;
39 expand: string -> (int * string) list;
40 extended: bool
41 }
42
43 -type payload = unit
44 -include "libnet/rt_proto.proto"
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
60 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
61 %% Messages envoyés/reçus %%
62 %% Different structure between server and client %%
63 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
64 -define (Ehlo host) = "EHLO "~ host "\r\n"
65 -define (Helo host) = "HELO "~ host "\r\n"
66 -define (From str) = "MAIL FROM:<"~ str ">\r\n"
67 -define (To str) = "RCPT TO:<"~ str ">\r\n"
68 -define Data = "DATA\r\n"~
69 -define Dot = ".\r\n"
70 -define DotDot = "..\r\n"
71 -define Crlf = "\r\n"
72 -define (Vrfy str) = "VRFY "~ str "\r\n"
73 -define (Expn str) = "EXPN "~ str "\r\n"
74 -define Noop = "NOOP\r\n"~
75 -define Rset = "RSET\r\n"~
76 -define Quit = "QUIT\r\n"~
77 -define (ENs (num : int, str)) = num "-" str "\r\n"
78 -define (Ns (num : int, str)) = num " " str "\r\n"
79 -define (RawInput str) = !".\r\n" !"..\r\n" str
80
81 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
82 %% L'automate %%
83 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
84 +on_connection(state : state):
85 {{ eprintf "on_connection\n"; Pervasives.flush stderr }}
86 let str = {{ sprintf "%s %s" state.server_domain state.hello_message }}
87 send(Ns (220,str));
88 wait_for_hello(state)
89
90 wait_for_hello(state : state):
91 receive
92 | Ehlo domain -> send_greeting({{ { state with client_domain = domain; extended = true } }})
93 | Helo domain -> send_greeting({{ { state with client_domain = domain; extended = false } }})
94 | Vrfy str -> let resp = {{ state.verify str }} send(Ns resp); wait_for_hello(state)
95 | Expn str -> let resp = {{ msglst (state.expand str) }} send_all(resp); wait_for_hello(state)
96 | Noop -> send(Ns(250,"Ok")); wait_for_hello(state)
97 | Rset -> send(Ns(250,"Ok")); wait_for_hello(state)
98 | Quit -> send(Ns(221,"Bye")); -!-
99 | RawInput _ -> send(Ns(500,"Command not recognised")); wait_for_hello(state)
100 | _ -> send(Ns(502,"Command not implemented")); wait_for_hello(state)
101 catch
102 | exn -> error({{ sprintf "wait_for_hello: exn=%s" (Printexc.to_string exn) }}, state)
103
104 send_greeting(state : state):
105 let str = {{ sprintf "Hello %s" state.client_domain }}
106 send(Ns (250,str));
107 wait_for_message(state, {{ { from=""; dests=[]; body=ContentNone } }})
108
109 wait_for_message(state : state, email : email):
110 receive
111 | From sender ->
112 if {{ email.from <> "" }}
113 then
114 send(Ns(503,"Bad sequence of commands"));
115 wait_for_message(state, email)
116 else
117 let email = {{ { email with from = sender } }}
118 send(Ns (250,"Ok"));
119 wait_for_message(state, email)
120 | To recipient ->
121 let email = {{ { email with dests = recipient::email.dests } }}
122 send(Ns (250,"Ok"));
123 wait_for_message(state, email)
124 | Data ->
125 send(Ns (354,"End data with <CR><LF>.<CR><LF>"));
126 get_data(state, email, false)
127 | Vrfy str -> let resp = {{ state.verify str }} send(Ns resp); wait_for_message(state,email)
128 | Expn str -> let resp = {{ msglst (state.expand str) }} send_all(resp); wait_for_message(state,email)
129 | Noop -> send(Ns(250,"Ok")); wait_for_message(state,email)
130 | Rset -> send(Ns(250,"Ok")); wait_for_hello(state)
131 | Quit -> send(Ns(221,"Bye")); -!-
132 | RawInput _ -> send(Ns(500,"Command not recognised")); wait_for_hello(state)
133 | _ -> send(Ns(502,"Command not implemented")); wait_for_hello(state)
134 catch
135 | exn -> error({{ sprintf "exn: %s" (Printexc.to_string exn) }}, state)
136
137 get_data(state : state, email : email, last_was_crlf : bool):
138 %% upto data = "\r\n.\r\n";
139 %% debug {{ eprintf "data='%s'\n" (String.escaped data) }}
140 %% let email = {{ { email with body = content_add (data^"\r\n") email.body } }}
141 %% process_email(state, email)
142 receive
143 | RawInput str ->
144 debug {{ eprintf "get_data: RawInput='%s'\n" (String.escaped str); Pervasives.flush stderr }}
145 let email = {{ { email with body = content_add str email.body } }}
146 get_data(state, email, {{ String.is_suffix "\r\n" str }})
147 | Crlf ->
148 debug {{ eprintf "get_data: Crlf\n"; Pervasives.flush stderr }}
149 let email = {{ { email with body = content_add "\r\n" email.body } }}
150 get_data(state, email, true)
151 | Dot ->
152 debug {{ eprintf "get_data: Dot last_was_crlf:%b\n" last_was_crlf; Pervasives.flush stderr }}
153 if {{ last_was_crlf }}
154 then process_email(state, email)
155 else
156 let email = {{ { email with body = content_add ".\r\n" email.body } }}
157 get_data(state, email, true)
158 | DotDot ->
159 debug {{ eprintf "get_data: DotDot\n"; Pervasives.flush stderr }}
160 let email = {{ { email with body = content_add ".\r\n" email.body } }}
161 get_data(state, email, true)
162 | Vrfy str -> let resp = {{ state.verify str }} send(Ns resp); get_data(state,email,last_was_crlf)
163 | Expn str -> let resp = {{ msglst (state.expand str) }} send_all(resp); get_data(state,email,last_was_crlf)
164 | Noop -> send(Ns(250,"Ok")); get_data(state,email,last_was_crlf)
165 | Rset -> send(Ns(250,"Ok")); wait_for_hello(state)
166 | Quit -> send(Ns(221,"Bye")); -!-
167 | _ -> send(Ns(502,"Command not implemented")); wait_for_hello(state)
168 catch
169 | exn -> error({{ sprintf "exn: %s" (Printexc.to_string exn) }}, state)
170
171 process_email(state:state, email:email):
172 debug {{ eprintf "process_email\n"; Pervasives.flush stderr }}
173 let reply = {{ Ns (state.callback email) }}
174 send(reply);
175 wait_for_quit(state)
176
177 wait_for_quit(state):
178 receive
179 | Vrfy str -> let resp = {{ state.verify str }} send(Ns resp); wait_for_quit(state)
180 | Expn str -> let resp = {{ msglst (state.expand str) }} send_all(resp); wait_for_quit(state)
181 | Noop -> send(Ns(250,"Ok")); wait_for_quit(state)
182 | Rset -> send(Ns(250,"Ok")); wait_for_hello(state)
183 | Quit -> send(Ns(221,"Bye")); -!-
184 | RawInput _ -> send(Ns(500,"Command not recognised")); wait_for_hello(state)
185 | _ -> send(Ns(502,"Command not implemented")); wait_for_hello(state)
186 catch
187 | exn -> error({{ sprintf "exn: %s" (Printexc.to_string exn) }}, state)
188
189 error(msg : string, _state : state):
190 send(Ns(451,"Server error"));
191 debug {{ eprintf "error %s\n" msg; Pervasives.flush stderr }}
192 {{ Logger.error "Error: %s" msg }}
193 -!-
194
Something went wrong with that request. Please try again.