Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tag: v1502
Fetching contributors…

Cannot retrieve contributors at this time

210 lines (190 sloc) 8.17 kb
% -*-erlang-*-
%
% Copyright © 2011, 2012 MLstate
%
% This file is part of OPA.
%
% OPA is free software: you can redistribute it and/or modify it under the
% terms of the GNU Affero General Public License, version 3, as published by
% the Free Software Foundation.
%
% OPA is distributed in the hope that it will be useful, but WITHOUT ANY
% WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
% FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
% more details.
%
% You should have received a copy of the GNU Affero General Public License
% along with OPA. If not, see <http://www.gnu.org/licenses/>.
%
-generate server
-debugvar PROTOCOL_DEBUG
-protocol SMTP
-open Printf
-open Rcontent
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Les types %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-type email = { from : string ; dests : string list ; body : content }
-type state = {
server_domain: string;
server_port: int;
hello_message: string;
client_domain: string;
callback: email -> ((int * string) -> unit) -> unit;
verify: string -> int * string;
expand: string -> (int * string) list;
extended: bool
}
-type payload = unit
-include "libnet/rt_proto.proto"
-type runtime = {
rt_plim : int;
rt_dialog_name : string;
rt_on_close : Scheduler.t -> unit;
rt_proto : rt_proto;
}
{{
let rec msglst = function
| [] -> []
| [(c,s)] -> [Ns (c,s)]
| ((c,s)::rest) -> (ENs (c,s))::(msglst rest)
}}
[[
let unstuff(last_was_crlf, str) =
let str =
if last_was_crlf && String.length(str) >= 2 && str.[0] = '.' && str.[1] = '.'
then String.sub str 1 (String.length(str) - 1)
else str
in
String.replace str "\r\n.." "\r\n.";;
]]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Messages envoyés/reçus %%
%% Different structure between server and client %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-define (Ehlo host) = "EHLO "~ host "\r\n"
-define (Helo host) = "HELO "~ host "\r\n"
-define (From str) = "MAIL FROM:<"~ str ">\r\n"
-define (To str) = "RCPT TO:<"~ str ">\r\n"
-define Data = "DATA\r\n"~
-define Dot = ".\r\n"
-define DotDot = "..\r\n"
-define Crlf = "\r\n"
-define (Vrfy str) = "VRFY "~ str "\r\n"
-define (Expn str) = "EXPN "~ str "\r\n"
-define Noop = "NOOP\r\n"~
-define Rset = "RSET\r\n"~
-define Quit = "QUIT\r\n"~
-define (ENs (num : int, str)) = num "-" str "\r\n"
-define (Ns (num : int, str)) = num " " str "\r\n"
-define (RawInput str) = !".\r\n" !"..\r\n" str
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% L'automate %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+on_connection(state : state):
{{ eprintf "on_connection\n"; Pervasives.flush stderr }}
let str = {{ sprintf "%s %s" state.server_domain state.hello_message }}
send(Ns (220,str));
wait_for_hello(state)
wait_for_hello(state : state):
receive
| Ehlo domain -> send_greeting({{ { state with client_domain = domain; extended = true } }})
| Helo domain -> send_greeting({{ { state with client_domain = domain; extended = false } }})
| Vrfy str -> let resp = {{ state.verify str }} send(Ns resp); wait_for_hello(state)
| Expn str -> let resp = {{ msglst (state.expand str) }} send_all(resp); wait_for_hello(state)
| Noop -> send(Ns(250,"Ok")); wait_for_hello(state)
| Rset -> send(Ns(250,"Ok")); wait_for_hello(state)
| Quit -> send(Ns(221,"Bye")); -!-
| RawInput _ -> send(Ns(500,"Command not recognised")); wait_for_hello(state)
| _ -> send(Ns(502,"Command not implemented")); wait_for_hello(state)
catch
| exn -> error({{ sprintf "wait_for_hello: exn=%s" (Printexc.to_string exn) }}, state)
send_greeting(state : state):
let str = {{ sprintf "Hello %s" state.client_domain }}
send(Ns (250,str));
wait_for_message(state, {{ { from=""; dests=[]; body=ContentNone } }})
wait_for_message(state : state, email : email):
receive
| From sender ->
if {{ email.from <> "" }}
then
send(Ns(503,"Bad sequence of commands"));
wait_for_message(state, email)
else
let email = {{ { email with from = sender } }}
send(Ns (250,"Ok"));
wait_for_message(state, email)
| To recipient ->
let email = {{ { email with dests = recipient::email.dests } }}
send(Ns (250,"Ok"));
wait_for_message(state, email)
| Data ->
send(Ns (354,"End data with <CR><LF>.<CR><LF>"));
get_data(state, email, false)
| Vrfy str -> let resp = {{ state.verify str }} send(Ns resp); wait_for_message(state,email)
| Expn str -> let resp = {{ msglst (state.expand str) }} send_all(resp); wait_for_message(state,email)
| Noop -> send(Ns(250,"Ok")); wait_for_message(state,email)
| Rset -> send(Ns(250,"Ok")); wait_for_hello(state)
| Quit -> send(Ns(221,"Bye")); -!-
| RawInput _ -> send(Ns(500,"Command not recognised")); wait_for_hello(state)
| _ -> send(Ns(502,"Command not implemented")); wait_for_hello(state)
catch
| exn -> error({{ sprintf "exn: %s" (Printexc.to_string exn) }}, state)
get_data(state : state, email : email, last_was_crlf : bool):
%% upto data = "\r\n.\r\n";
%% debug {{ eprintf "data='%s'\n" (String.escaped data) }}
%% let email = {{ { email with body = content_add (data^"\r\n") email.body } }}
%% process_email(state, email)
receive
| RawInput str ->
let str = {{ unstuff(last_was_crlf,str) }}
debug {{ eprintf "get_data: RawInput='%s'\n" (String.escaped str); Pervasives.flush stderr }}
let email = {{ { email with body = content_add str email.body } }}
get_data(state, email, {{ String.is_suffix "\r\n" str }})
| Crlf ->
debug {{ eprintf "get_data: Crlf\n"; Pervasives.flush stderr }}
let email = {{ { email with body = content_add "\r\n" email.body } }}
get_data(state, email, true)
| Dot ->
debug {{ eprintf "get_data: Dot last_was_crlf:%b\n" last_was_crlf; Pervasives.flush stderr }}
if {{ last_was_crlf }}
then process_email(state, email)
else
let email = {{ { email with body = content_add ".\r\n" email.body } }}
get_data(state, email, true)
| DotDot ->
debug {{ eprintf "get_data: DotDot\n"; Pervasives.flush stderr }}
let email = {{ { email with body = content_add ".\r\n" email.body } }}
get_data(state, email, true)
| Vrfy str -> let resp = {{ state.verify str }} send(Ns resp); get_data(state,email,last_was_crlf)
| Expn str -> let resp = {{ msglst (state.expand str) }} send_all(resp); get_data(state,email,last_was_crlf)
| Noop -> send(Ns(250,"Ok")); get_data(state,email,last_was_crlf)
| Rset -> send(Ns(250,"Ok")); wait_for_hello(state)
| Quit -> send(Ns(221,"Bye")); -!-
| _ -> send(Ns(502,"Command not implemented")); wait_for_hello(state)
catch
| exn -> error({{ sprintf "exn: %s" (Printexc.to_string exn) }}, state)
send_response(reply, state):
send(reply);
wait_for_quit(state)
process_email(state:state, email:email):
debug {{ eprintf "process_email\n"; Pervasives.flush stderr }}
let cpl = !"state.callback" << state.callback email >>
let res = {{ Ns(fst cpl, snd cpl) }}
send_response(res, state)
wait_for_quit(state):
receive
| Vrfy str -> let resp = {{ state.verify str }} send(Ns resp); wait_for_quit(state)
| Expn str -> let resp = {{ msglst (state.expand str) }} send_all(resp); wait_for_quit(state)
| Noop -> send(Ns(250,"Ok")); wait_for_quit(state)
| Rset -> send(Ns(250,"Ok")); wait_for_hello(state)
| Quit -> send(Ns(221,"Bye")); -!-
| RawInput _ -> send(Ns(500,"Command not recognised")); wait_for_hello(state)
| _ -> send(Ns(502,"Command not implemented")); wait_for_hello(state)
catch
| exn -> error({{ sprintf "exn: %s" (Printexc.to_string exn) }}, state)
error(msg : string, _state : state):
send(Ns(451,"Server error"));
debug {{ eprintf "error %s\n" msg; Pervasives.flush stderr }}
{{ Logger.error "Error: %s" msg }}
-!-
Jump to Line
Something went wrong with that request. Please try again.