smtpServerCore.proto

% -*-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 }}
  -!-