Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/defdata/smtp.src

Text File | 1988-05-03 | 67.0 KB | 2,370 lines

--::::::::::::::
--slog.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01133-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         slog.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_logger is

procedure error_log (msg : string) ;

end ssmtp_logger ;


-- debug version
with text_io ; use text_io ;
package body ssmtp_logger is

procedure error_log (msg : string) is
begin
--- may also record connection info, such as usmtp host, usmtp name, etc
put_line(msg) ;
end error_log ;

end ssmtp_logger ;
--::::::::::::::
--sglobs.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01132-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         sglobs.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_globals is

-- here are the conditions which interrupt
--  normal flow of control:

sudden_connection_close : exception ;
 -- connection closed or connection aborted
transport_error         : exception ;
 -- unexpected message from transport
ssmtp_reset             : exception ;
 -- reset command received
ssmtp_quit              : exception ;
 -- quit command received


--&KJW 21-jul-85 transport_connection_open : boolean ;
transport_connection_open : boolean := false;    --&KJW 21-jul-85
 -- state of the transport connection


--
-- this is to support the list of local receivers
-- smtp_rcpt creates this list
-- smtp_deliver uses it
--
subtype user_name_type is string (1..80) ;
subtype host_name_type is string (1..80) ;
max_rcpt           : constant integer := 80 ;
rcpt_list          : array (1..max_rcpt) of user_name_type ;
number_of_rcpt     : integer range 0..max_rcpt ;

source_host        : host_name_type ;
source_host_length : integer range 0..80 ;
source_name        : user_name_type ;
source_name_length : integer range 0..80 ;

--
-- used to parse the smtp commands
--
max_command_length : constant integer := 80 ;
command            : string (1..4) ;
  -- 4 letter smtp command, lower case
command_parms      : string (1..max_command_length) ;
  -- the rest of the received command
parm_length        : integer range 0..max_command_length ;

--
-- where the mail message is saved
--
type lines is record
  message_line : string(1..512) ;
  line_length  : integer ;
  end record ;
max_message_length : constant integer := 2048 ;
message            : array (1..max_message_length) of lines ;
message_length     : integer ;

procedure reset_receive_buffers ;
  -- prepare to receive a new message

end ssmtp_globals ;

package body ssmtp_globals is

procedure reset_receive_buffers is
  begin
  number_of_rcpt := 0 ;
  message_length := 0 ;
end reset_receive_buffers ;


end ssmtp_globals ;

--::::::::::::::
--strans_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01141-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         strans_.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_transport is
--
-- all the procedures required to interface to the transport service
--

procedure send_passive_open ;
-- send a listen on the well-known smtp socket

procedure wait_for_open  ;
-- wait for the open ok message

procedure close_connection ;
-- send a close to transport layer, wait for close ok message

procedure send_string (str : in string) ;
-- send a character string via the transport protocol

procedure get_command ;
-- this procedure gets an entire command from the transport layer
-- puts the first four letters, in lower case, in ssmtp_globals.command
-- and leaves the rest in ssmtp_globals.command_line
-- may raise the following exceptions:
--   sudden_connection_close
--   transport_error

procedure get_a_line( str : out string;
                      len : out integer ) ;
-- this procedure gets an entire line from the transport layer
-- may raise the following exceptions:
--   sudden_connection_close
--   transport_error


end ssmtp_transport ;
--::::::::::::::
--strans.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01142-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         strans.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
with ssmtp_globals ;         use ssmtp_globals ;
with text_io ;               use text_io ;
with ssmtp_logger ;          use ssmtp_logger ;
with with_ulp_communicate ;  use with_ulp_communicate ;
with buffer_data;            use buffer_data ;

package body ssmtp_transport is

package int_io_16 is new integer_io(sixteen_bits) ;

--------------------------------------------------------------------------------

current_lcn : lcn_ptr_type ;

--------------------------------------------------------------------------------


--
-- This is a local procedure to send a receive request to tcp
-- We should always have a few outstanding receives for tcp to put data into
--
procedure send_a_receive is
request_ok : boolean ;
tcp_params : with_ulp_communicate.message(receive) ;
a_buf      : packed_buffer_ptr ;
begin
buffget(a_buf,1) ;
if a_buf = null then
    error_log("Could not get a buffer") ;
    raise constraint_error ;   -- crash the connection
end if ;
tcp_params.receive_parameters.local_connection_name := current_lcn ;
tcp_params.receive_parameters.bufptr := a_buf ;
tcp_params.receive_parameters.byte_count := 190 ;
message_for_tcp(tcp_params,request_ok) ;
if not request_ok then
   raise transport_error ;
end if ;
exception
  when others =>
    error_log("Exception in send_a_receive") ;
    raise ;
end send_a_receive ;



procedure send_passive_open is
request_ok : boolean ;
tcp_params : with_ulp_communicate.message(open) ;
begin
-- do a listen on the tcp port for smtp mail service.
tcp_params.open_parameters.local_connection_name := current_lcn ;
tcp_params.open_parameters.local_port := 25 ;
tcp_params.open_parameters.foreign_port := 0 ;
tcp_params.open_parameters.foreign_net_host := 0 ;
tcp_params.open_parameters.active_passive := passive ;
tcp_params.open_parameters.buffer_size := 0 ;
tcp_params.open_parameters.timeout := 2000 ;
tcp_params.open_parameters.security := 0 ;
tcp_params.open_parameters.precedence := 0 ;
tcp_params.open_parameters.options := (others => 0) ;
message_for_tcp(tcp_params,request_ok) ;
current_lcn := tcp_params.open_parameters.local_connection_name ;
if not request_ok then
   raise transport_error ;
end if ;
exception
  when others =>
    error_log("Exception in send_passive_open") ;
    raise ;
end ;




--------------------------------------------------------------------------------
--------------------------------------------------------------------------------




procedure wait_for_open is
reply : user_message ;
begin
loop
  reply.local_connection_name := current_lcn ;
  wait_for_tcp_message (reply) ;
  case reply.message_number is
    when 23 =>
      send_a_receive ; -- leave a receive pending
      transport_connection_open := true;    --&KJW 21-jul-85
      exit ;
    when 14 =>
      current_lcn.lcn_ptr := reply.local_connection_name.lcn_ptr ;
    when 2 | 5 | 9 | 11 | 20 =>
      put("could not open, reason code = ") ;
      int_io_16.put(reply.message_number) ;
      put_line (" ." ) ;
    when 8 | 16 =>
      put_line("connection aborted") ;
      raise transport_error ;
    when others =>
      put("connection message") ;
      int_io_16.put(reply.message_number) ;
      new_line ;
    end case ;
end loop ;
exception
  when others =>
    error_log("Exception in wait_for_open") ;
    raise ;
end wait_for_open ;




--------------------------------------------------------------------------------
--------------------------------------------------------------------------------



procedure close_connection is
--
-- Send a close command to tcp and wait for a connection_closed response.
--
tcp_params : with_ulp_communicate.message(close) ;
reply : user_message ;
request_ok : boolean ;
begin
--&KJW 11-jul-85 put_line("closing transport connection") ;
--&KJW 11-jul-85 tcp_params.abort_close_parameters.local_connection_name := current_lcn ;
--&KJW 11-jul-85 message_for_tcp(tcp_params,request_ok) ;
--&KJW 11-jul-85 if not request_ok then
--&KJW 11-jul-85   raise transport_error ;
--&KJW 11-jul-85 end if ;
--&KJW 11-jul-85 reply.local_connection_name := current_lcn ;
loop
reply.local_connection_name := current_lcn ;
wait_for_tcp_message (reply) ;
case reply.message_number is
  when 8 | 16 =>
    put_line("connection aborted") ;
    transport_connection_open := false;        --&KJW 21-jul-85
    exit ;
  when 6 =>
    tcp_params.abort_close_parameters.local_connection_name := current_lcn ;
    message_for_tcp(tcp_params,request_ok) ;      --&KJW 11-jul-85
    if not request_ok then            --&KJW 11-jul-85
      raise transport_error ;            --&KJW 11-jul-85
    end if ;                    --&KJW 11-jul-85
    reply.local_connection_name := current_lcn ;--&KJW 11-jul-85
    wait_for_tcp_message (reply) ;        --&KJW 11-jul-85
    case reply.message_number is        --&KJW 11-jul-85
      when 8 | 16 =>                --&KJW 11-jul-85
        put_line("connection aborted") ;    --&KJW 11-jul-85
        transport_connection_open := false;    --&KJW 21-jul-85
        exit ;                    --&KJW 11-jul-85
      when 18 =>                --&KJW 11-jul-85
        put_line("connection closed") ;
        transport_connection_open := false;    --&KJW 21-jul-85
        exit ;
      when others =>                --&KJW 11-jul-85
        put("connection message ") ;        --&KJW 11-jul-85
        int_io_16.put(reply.message_number) ;   --&KJW 11-jul-85
        new_line ;                --&KJW 11-jul-85
    end case;                    --&KJW 11-jul-85
  when others =>
    put("connection message") ;
    int_io_16.put(reply.message_number) ;
    new_line ;
  end case ;
end loop ;
exception
  when others =>
    error_log("Exception in close_connection") ;
    raise ;
end close_connection ;



--------------------------------------------------------------------------------
--------------------------------------------------------------------------------



procedure send_string (str : in string) is
a_buffer : packed_buffer_ptr ;
send_block : send_params ;
tcp_params : with_ulp_communicate.message(send) ;
request_ok : boolean ;
begin
put("S: ") ;
put_line(str) ;
buffget(a_buffer,1) ;
if a_buffer = null then
    error_log("Could not get a buffer") ;
    raise constraint_error ;   -- crash the connection
end if ;
---a_buffer.tcp_ptr := maximum_datagram_size - sixteen_bits(str'length) ;
-- patch for incorrect buffer spec
a_buffer.tcp_ptr := 254 - sixteen_bits(str'length) ;
--- a_buffer.size := str'length ;  --- patch for tcp error
a_buffer.size := str'length + 1 ;  --- patch for tcp error
-- put the string bytes into the end of the buffer
for i in 1..str'length loop
  a_buffer.byte(a_buffer.tcp_ptr + sixteen_bits(i))
      := character'pos(str(i)) ;
end loop ;
send_block.local_connection_name := current_lcn ;
send_block.bufptr := a_buffer ;
send_block.byte_count := a_buffer.size ;
send_block.push_flag  := 0 ;
send_block.urg_flag := 0 ;
send_block.timeout  := 2000 ;
tcp_params.send_parameters := send_block ;
message_for_tcp(tcp_params,request_ok) ;
if not request_ok then
  raise transport_error ;
end if ;
exception
  when others =>
    error_log("Exception in send_string") ;
    raise ;
  end ;



--------------------------------------------------------------------------------
--------------------------------------------------------------------------------





procedure process_data ( buf : packed_buffer_ptr;
                         done : out boolean) is
data_byte : integer ;
len       : integer ;
begin
len := integer(buf.telnet_ptr - buf.tcp_ptr);
if len < 4 then
  command := "    " ;       --- blank it out
  put_line (" Bad command...incomplete") ;
else
  for i in 1..4 loop
    data_byte := integer(buf.byte(buf.tcp_ptr + sixteen_bits(i)-1)) ;
    if ((data_byte >= character'pos('A'))
          and (data_byte <= character'pos('Z'))) then
       command(i) := character'val( data_byte - character'pos('A')
                                + character'pos('a')) ; -- make it lower case
    else
      command(i) := character'val(data_byte) ;
    end if ;
  end loop ;
end if ;
command_parms := (others => ' ') ;    --&KJW 21-jul-85
if len <= 4 then
  --&KJW 21-jul-85 command_parms := (others => ' ') ;
  parm_length   := 0 ;
else
  parm_length := len - 4 ;
  for i in 1..parm_length loop
    data_byte := integer(buf.byte(sixteen_bits(i)+buf.tcp_ptr+3))  ;
    --&KJW 21-jul-85 if ((data_byte >= character'pos('A')) and (data_byte <= character'pos('Z'))) then
    --&KJW 21-jul-85    command_parms(i) := character'val(data_byte - character'pos('A')
    --&KJW 21-jul-85                                + character'pos('a')) ; -- make it lower case
    --&KJW 21-jul-85 else
    --&KJW 21-jul-85   command_parms(i) := character'val(data_byte) ;
    --&KJW 21-jul-85 end if ;
    command_parms(i) := character'val(data_byte) ;
  end loop ;
end if ;
put("R: ") ;
put(command) ;
put_line(command_parms) ;
done := true ;      -- single segment replies only for test
exception
  when others =>
    error_log("Exception in process_data") ;
    raise ;

end process_data ;


-------------------------------------------------------------------------------


procedure get_command is
  len : integer ;          -- test
  cmd : string (1..256) ;  -- test
  reply_done : boolean := false ;
  tcp_reply : with_ulp_communicate.user_message ;
begin
command := "    " ;
while not reply_done loop
  tcp_reply.local_connection_name := current_lcn ;
  wait_for_tcp_message (tcp_reply) ;
  case tcp_reply.message_number is
  when 16 =>
    put_line("connection aborted") ;
     raise sudden_connection_close ;
  when 10 =>
    process_data (tcp_reply.data_buffer, reply_done) ;
    send_a_receive ;  -- replace the receive
  when others =>
    put("connection message") ;
    int_io_16.put(tcp_reply.message_number) ;
    new_line ;
  end case ;
end loop ;
exception
  when others =>
    error_log("exception in get_command") ;
    raise ;
end get_command ;



-------------------------------------------------------------------------------
-------------------------------------------------------------------------------


procedure process_str  ( buf  : packed_buffer_ptr;
                         done : out boolean;
                         str  : out string ;
                         len  : out integer ) is
str1      : string(1..255)  ;
len1      : integer ;
data_byte : integer ;
begin
len1 := integer(buf.telnet_ptr - buf.tcp_ptr);
for i in 1..len1 loop
  str1(i) := character'val(buf.byte(buf.tcp_ptr + sixteen_bits(i)-1)) ;
  end loop ;
put("R: ") ;
put_line(str1(1..len1)) ;
str(1..len1) := str1(1..len1) ;
len := len1 ;
done := true ;      -- single segment replies only for test
exception
  when others =>
    error_log("Exception in process_str") ;
    raise ;

end process_str ;


-------------------------------------------------------------------------------



procedure get_a_line( str : out string ;
                      len : out integer ) is
str_done : boolean := false ;
tcp_reply : with_ulp_communicate.user_message ;
begin
while not str_done loop
  tcp_reply.local_connection_name := current_lcn ;
  wait_for_tcp_message (tcp_reply) ;
  case tcp_reply.message_number is
  when 16 =>
    put_line("connection aborted") ;
     raise sudden_connection_close ;
  when 10 =>
    process_str (tcp_reply.data_buffer, str_done, str, len) ;
    send_a_receive ;  -- replace the receive
  when others =>
    put("connection message") ;
    int_io_16.put(tcp_reply.message_number) ;
    new_line ;
  end case ;
end loop ;
exception
  when others =>
    error_log("exception in get_a_line") ;
    raise ;
end get_a_line ;





end ssmtp_transport ;
--::::::::::::::
--sreps_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01136-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         sreps_.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_replies is

procedure send_ready_message ;

procedure send_helo_ok ;

procedure send_mail_ok ;

procedure send_rcpt_ok ;

procedure send_rcpt_not_ok ;

procedure send_no_room ;

procedure send_data_ok ;

procedure send_completed_ok ;

procedure send_completed_not_ok ;

procedure send_quit_ok ;

procedure bad_command ;

end ssmtp_replies ;

--::::::::::::::
--sreps.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01137-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         sreps.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------

with ssmtp_transport ; use ssmtp_transport ;
with text_io ;         use text_io ;
with ssmtp_logger ;    use ssmtp_logger ;
with ssmtp_globals ;   use ssmtp_globals ;

package body ssmtp_replies is

procedure send_ready_message is
  begin
  send_string("220  SMTP mail service ready") ;
  exception
    when others =>
      error_log ("Exception in send_helo_ok") ;
  end send_ready_message ;

procedure send_helo_ok is
  begin
  send_string("250 Helo ok") ;
  exception
    when others =>
    error_log  ("Exception in send_helo_ok") ;
  end send_helo_ok ;

procedure send_mail_ok is
  begin
  send_string("250 mail ok") ;
  exception
    when others =>
    error_log  ("Exception in send_mail_ok") ;
  end send_mail_ok ;

procedure send_rcpt_ok is
  begin
  send_string("250 rcpt ok") ;
  exception
    when others =>
      error_log  ("Exception in send_rcpt_ok") ;
  end send_rcpt_ok ;

procedure send_rcpt_not_ok is
  begin
  send_string("550 User not local, cannot forward") ;
  exception
    when others =>
      error_log  ("Exception in send_rcpt_not_ok") ;
  end send_rcpt_not_ok ;

procedure send_no_room is
  begin
  send_string("501 out of resources") ;
  error_log("Ran out of resources") ;
  exception
    when others =>
      error_log  ("Exception in send_no_room ") ;
  end send_no_room ;

procedure send_data_ok is
  begin
  send_string("354 begin data... ") ;
  exception
    when others =>
      error_log  ("Exception in send_data_ok") ;
  end send_data_ok ;

procedure send_completed_ok is
  begin
  send_string("250 mail sent") ;
  exception
    when others =>
      error_log  ("Exception in send_completed_ok") ;
  end send_completed_ok ;

procedure send_completed_not_ok is
  begin
  send_string("250 mail not sent to some recipients ") ;
  exception
    when others =>
      error_log  ("Exception in send_completed_not_ok") ;
  end send_completed_not_ok ;


procedure send_quit_ok is
  begin
  send_string("221 SMTP closing connection") ;
  exception
    when others =>
      error_log  ("Exception in send_quit_ok") ;
  end send_quit_ok ;


procedure bad_command is
  begin
  if command = "rset" then
    raise ssmtp_reset ;
  elsif command = "quit" then
    raise ssmtp_quit ;
  else
    send_string("451 Unexpected or unimplemented command") ;
  end if ;
  exception
    when ssmtp_reset | ssmtp_quit =>
      raise ;
    when others =>
      error_log ("Exception in bad_command") ;
      raise ;
  end bad_command ;



end ssmtp_replies ;

--::::::::::::::
--sdel_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01130-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         sdel_.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_deliver is

procedure deliver_mail ;

end ssmtp_deliver ;


--::::::::::::::
--sdel.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01131-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         sdel.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
with ssmtp_globals ;   use ssmtp_globals ;
with ssmtp_logger ;    use ssmtp_logger ;
with ssmtp_replies ;   use ssmtp_replies ;
with text_io ;         use text_io ;
with system;           use system ;

package body ssmtp_deliver is

procedure copy_mail(user_name : user_name_type; ok : out boolean ) is
smtp_mail : file_type ;
begin
  ok := true ;
  create(smtp_mail,out_file,"smtp_mail.txt") ;
  for i in 1..message_length loop
    put_line(smtp_mail,message(i).message_line(1..message(i).line_length)) ;
  end loop ;
  close(smtp_mail) ;
  exception
    when others =>
      error_log("Exception in copy_mail");
  end ;


procedure deliver_mail is
all_ok, delivered_ok : boolean := true ;
rcpt_file : file_type ;
begin
  create(rcpt_file,out_file,"rcpt_list.txt") ;
  for i in 1..number_of_rcpt loop
    put_line(rcpt_file,rcpt_list(i)) ;
    copy_mail(rcpt_list(i),delivered_ok);
    all_ok := delivered_ok and all_ok ;
  end loop ;
  close(rcpt_file);
  if all_ok then
    send_completed_ok ;
  else
    send_completed_not_ok ;
  end if ;
  exception
    when others =>
      error_log("Exception in deliver_mail");
end ;

end ssmtp_deliver ;
--::::::::::::::
--sconn_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01128-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         sconn_.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_connections is
--
-- This package contains support for establishing the connection
--  between the ssmtp and a usmtp.
--
procedure establish_transport_connection ;
--
-- This procedure sets up the transport connection between the
-- ssmtp and a usmtp. It waits for a usmtp to call it, performs
-- any handshaking required, and sends the ssmtp greeting reply.
--
procedure establish_sender ;
--
-- this procedure gets the helo command from the usmtp and saves the
-- usmtp host string. Currently does not verify the host name string.
--
end ssmtp_connections ;


--::::::::::::::
--sconn.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01129-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         sconn.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------


with ssmtp_transport ;    use ssmtp_transport ;
with ssmtp_globals ;      use ssmtp_globals ;
with ssmtp_replies ;      use ssmtp_replies ;
with text_io ;            use text_io ;
with ssmtp_logger ;       use ssmtp_logger ;

package body ssmtp_connections is

--
--   Implementation for :  vax 11/780
--                         dec ada
--                         tcp transport service
--


procedure establish_transport_connection is
begin
if not transport_connection_open then
  send_passive_open ;
  wait_for_open ;
  end if ;
loop
  begin
    send_ready_message ;
    reset_receive_buffers ;
    get_command ;
    if command = "helo" then
      source_host := command_parms ; -- save the "from" address as is
      send_helo_ok ;
      exit ;
    else
        bad_command ;
    end if ;
  exception
    when ssmtp_reset =>
      put_line("RSET received") ;
    when others =>
      error_log ("Exception in establish_transport_connection") ;
      raise ;
  end ;
end loop ;

end ;




procedure establish_sender is
begin
  get_command ;
  if command = "mail" then
    source_name := command_parms ;
    send_mail_ok ;
  else
    bad_command ;
  end if ;
  exception
    when ssmtp_reset =>
      put_line("RSET received") ;
    when others =>
      error_log ("Exception in establish sender") ;
      raise ;
  end establish_sender ;


end ssmtp_connections ;


--::::::::::::::
--stext_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01139-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         stext_.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_text is
procedure expect_text ;
-- this program reads in mail from the transport layer and stores them
--  into ssmtp_globals.text as characters
--  exits upon end-of-mail indicator (i.e.  <crlf>.<crlf>)
--  may also exit with a raised exception:
--    ssmtp_quit :
--       if a quit command is received
--    ssmtp_reset :
--       if a reset is received
--    transport_close:
--       if a transport connection_aborted or connection_closed is found
--    transport_error :
--       if an unknown transport condition is found
--
end ssmtp_text ;


--::::::::::::::
--stext.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01140-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         stext.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------


with text_io;            use text_io ;
with ssmtp_transport ;   use ssmtp_transport ;
with ssmtp_logger ;      use ssmtp_logger ;
with ssmtp_globals ;     use ssmtp_globals;

package body ssmtp_text is

procedure expect_text is
line : string (1..256) ;
len : integer ;
begin
  send_string ("354 Start Mail Input") ;
  loop
    get_a_line(line,len) ;
    if line(1) = '.' then    --&KJW 21-jul-85
      exit when len = 1 ;
      message_length := message_length + 1 ;
      message(message_length).message_line(1..len-1) := line(2..len) ;
      message(message_length).line_length := len-1 ;
    else
      message_length := message_length + 1 ;
      message(message_length).message_line(1..len) := line(1..len) ;
      message(message_length).line_length := len ;
    end if ;            --&KJW 21-jul-85
    --&KJW 21-jul-85 message_length := message_length + 1 ;
    --&KJW 21-jul-85 message(message_length).message_line(1..len) := line(1..len) ;
    --&KJW 21-jul-85 message(message_length).line_length := len ;
    --&KJW 21-jul-85 exit when line(1) = '.' ;
  end loop ;
exception
  when others =>
    error_log ("Exception in ssmtp.expect_text") ;
end expect_text ;

end ssmtp_text ;


--::::::::::::::
--srcpt_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01134-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         srcpt_.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package ssmtp_rcpt is

  procedure expect_rcpt_list ;

end ssmtp_rcpt ;


--::::::::::::::
--srcpt.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01135-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         srcpt.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------

with ssmtp_transport ;    use ssmtp_transport ;
with ssmtp_globals ;      use ssmtp_globals ;
with ssmtp_replies ;      use ssmtp_replies ;
with text_io ;            use text_io ;
with ssmtp_logger ;       use ssmtp_logger ;

package body ssmtp_rcpt is

-- this table is system dependent, not really the best method

max_users : integer := 100 ;
user_name_table : array (1..max_users) of user_name_type ;
number_of_users : integer ;

procedure lookup_user_name(name       : in  user_name_type ;
                           user_local : out boolean) is
--- look up user in list
--- could make system call if available
begin
user_local := false ;
for i in 1..number_of_users loop
  if user_name_table(i) = name then
    user_local := true ;
    exit ;
  end if ;
end loop ;
exception
when others =>
  error_log("exception in lookup_user_name") ;
  raise ;
end lookup_user_name ;


procedure parse_user_name(user_local : out boolean;
                          user_name  : out user_name_type) is
ptr : integer := 0 ;
name : user_name_type := (others => ' ') ;
begin
user_name := (others => ' ') ;
user_local := false ;
for i in 1..parm_length loop
  if command_parms(i) /= ' ' then
    ptr := i ;
    exit ;
  end if ;
end loop ;
if ((ptr /= 0) and (ptr <= parm_length+3)) and then
    command_parms(ptr..ptr+2) = "to:" then
  for i in 1..(parm_length-(ptr+3)) loop
    name(i) := command_parms(i+ptr+3) ;
  end loop ;
  lookup_user_name(name,user_local) ;
  user_name := name ;
else
  put("bad format rcpt: ") ;
  put_line(command_parms) ;
end if ;
exception
when others =>
  error_log("exception in parse_user_name") ;
  raise ;
end parse_user_name ;

procedure expect_rcpt_list is
  user_local : boolean ;
  user_name  : user_name_type ;
  begin
  loop
    get_command ;
    if command = "rcpt" then
      parse_user_name(user_local,user_name) ;
      if not user_local then
        send_rcpt_not_ok  ;
      else
        if number_of_rcpt < max_rcpt then
          number_of_rcpt := number_of_rcpt + 1 ;
          rcpt_list(number_of_rcpt) := (others => ' ') ;
          rcpt_list(number_of_rcpt) := user_name ;
          send_rcpt_ok ;
        else
          send_no_room ;
        end if ;
      end if ;
    elsif command = "data" then
      exit ;
    else
      bad_command ;
    end if ;
    end loop ;
  exception
    when ssmtp_reset =>
      put_line("Reset in expect_rcpt_list");
      raise ssmtp_reset ;
    when ssmtp_quit =>
      put_line("Quit in expect_rcpt_list");
      raise ssmtp_quit ;
    when others =>
      error_log("exception in expect_rcpt_list");
      raise ;
end expect_rcpt_list ;


begin
--&KJW 11-jul-85 user_name_table(1)       := (others => ' ') ;
--&KJW 11-jul-85 user_name_table(1)(1..7) := "higgins" ;
--&KJW 11-jul-85 user_name_table(2)       := (others => ' ') ;
--&KJW 11-jul-85 user_name_table(2)(1..6) := "thomas" ;
--&KJW 11-jul-85 user_name_table(3)       := (others => ' ') ;
--&KJW 11-jul-85 user_name_table(3)(1..5) := "baldo" ;
--&KJW 11-jul-85 user_name_table(3)       := (others => ' ') ;
--&KJW 11-jul-85 user_name_table(3)(1..7) := "noscada" ;
--&KJW 11-jul-85 number_of_users := 4 ;

-- Read user names into user_name_table from file "usernames.lcl".
-- Each installation can configure allowable user identifiers via this file.
-- If the open for the file fails, then it is either in use (i.e. being editted)
-- or does not exist.  This version of the SMTP server cannot continue if there
-- are no local users since it does not forward mail to another node.

loop
  declare
    name_file : file_type ;
    last,index : natural ;
  begin
    open(name_file,in_file,"usernames.lcl") ;
    number_of_users := 0 ;
    while not end_of_file(name_file) loop
      index := number_of_users + 1;
      get_line (name_file, user_name_table(index), last) ;
      -- user names can be in any form; but they must NOT be preceeded by any
      -- "white space" (this implementation won't look for it or discard it).
      -- the length of a user name must NOT exceed the space reserved for it in
      -- the user_name_table (regardless of the unused space in other names).
      -- comments in the name table are introduced as Ada-style comments; how-
      -- ever, the two hyphens must be the first two characters in the line.
      if user_name_table(index)(1..2) /= "--" then
        user_name_table(index)(last+1 .. user_name_table(index)'Last)
             := (others => ' ') ;
        number_of_users := index ;
      end if ;
      exit when number_of_users >= max_users ;
    end loop ;
    close(name_file) ;
    exit ;
  exception
    when status_error =>    -- file is open; try again later
      delay 30.0;
    when name_error =>        -- file does not exist
      put_line("could not find file 'usernames.lcl'" &
               " in package body ssmtp_rcpt") ;
      raise ;
    when others =>        -- ???
      put_line("unknown exception in package body ssmtp_rcpt elaboration.") ;
      close(name_file) ;    -- just in case it was open
      raise;
  end ;
end loop ;

end ssmtp_rcpt;
--::::::::::::::
--ssmtp.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01138-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         ssmtp.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
with text_io;            use text_io ;
with ssmtp_globals ;     use ssmtp_globals ;
with ssmtp_replies ;     use ssmtp_replies ;
with ssmtp_connections ; use ssmtp_connections ;
with ssmtp_transport ;   use ssmtp_transport ;
with ssmtp_rcpt ;        use ssmtp_rcpt ;
with ssmtp_text ;        use ssmtp_text ;
with ssmtp_deliver ;     use ssmtp_deliver ;
with ssmtp_logger ;      use ssmtp_logger ;
with buffer_data ;       use buffer_data ;

procedure ssmtp is
begin
  buffer_data.init ;
  loop
    begin
    establish_transport_connection ;
    establish_sender ;
    loop
      begin
      reset_receive_buffers ;
      expect_rcpt_list ;
      expect_text ;
      deliver_mail ;
      exception
        when ssmtp_reset =>
          put_line("reset received") ;
          --send_reset_ok ;
      end ;
      end loop ;
  exception
    when ssmtp_quit =>
      put_line("quit received") ;
      send_quit_ok ;
      close_connection ;
      EXIT ;    -- for VAX/VMS  O N L Y !!! (let command file distribute mail)
    when ssmtp_reset =>
      put_line("reset received") ;
      --send_reset_ok ;
    when sudden_connection_close =>
      put_line("Transport connection closed") ;
    when transport_error =>
      put_line("Transport error ") ;
    when others =>
      error_log ("Unknown exception in server smtp... exiting") ;
      raise ;
   end ;
  end loop ;
end ssmtp ;

--::::::::::::::
--uutils_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01154-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         uutils.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------

-------------------------------------------------------------------------------
--
-- USMTP globals
--
package usmtp_utils is

  -- abnormal conditions:
  abort_usmtp : exception ;       -- user requests exit
  smtp_error  : exception ;       -- server sends error code (4xx or 5xx)
  unexpected_reply : exception ;  -- server sends insane reply
  tcp_reset   : exception ;       -- tcp resets connection

  -- implementation constraints
  max_line_len : constant integer := 80 ;


-- the following are the known replies to usmtp

open_ok      : constant string(1..3) := "220" ;
data_ok      : constant string(1..3) := "250" ;
send_data_ok : constant string(1..3) := "354" ;
rcpt_ok      : constant string(1..3) := "250" ;
will_forward : constant string(1..3) := "251" ;
helo_ok      : constant string(1..3) := "250" ;
quit_ok      : constant string(1..3) := "221" ;


end usmtp_utils ;

--::::::::::::::
--xhost_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01155-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         xhost_.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
with buffer_data ;      -- to import address type

package xhost is
--
-- Utilities to translate host names to host addresses
-- Only TCP format addresses supported
-- could add some table maintainence procedures here if desired
--
procedure translate_host_name_to_address
--
-- Look up the host name in the table and return the address.
--
   (host_name    :  in string ;
    host_id      : out buffer_data.thirtytwo_bits ;  -- an internet address
    host_name_ok : out boolean ) ;

end ;

--::::::::::::::
--xhost.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01156-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         xhost.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
with text_io ;       use text_io ;
with usmtp_utils ;   use usmtp_utils ;
with buffer_data ;   use buffer_data ;  -- for type thirtytwo_bits

package body xhost is

type name_id_pair is record
  name : string (1..80) ;
  id   : buffer_data.thirtytwo_bits ;
end record ;

a_blank_line : string (1..80) := (others => ' ') ;
a_name : string (1..80) ;
an_id  : thirtytwo_bits ;

host_name_table : array (1..10) of name_id_pair :=
    ( others => (a_blank_line, 0) ) ;

number_of_hosts : integer range 1..10 ;

procedure translate_host_name_to_address
--
-- Look up the host name in the table and return the address.
--
   (host_name    :  in string ;
    host_id      : out thirtytwo_bits ;
    host_name_ok : out boolean ) is
begin
host_name_ok := false ;
a_name := a_blank_line ;
a_name(1..host_name'length) := host_name ;
for i in 1..number_of_hosts loop
  if a_name = host_name_table(i).name then
    host_id := host_name_table(i).id ;
    host_name_ok := true ;
    exit ;
    end if ;
end loop ;
exception
  when others =>
    put_line("EXCEPTION IN TRANSLATE_HOST_NAME") ;
    raise ;
end ;


begin

a_name := a_blank_line ;
a_name(1..6) := "saturn" ;
an_id :=  1 ;
host_name_table (1) := (a_name, an_id) ;

a_name := a_blank_line ;
a_name(1..4) := "mars" ;
an_id := 2 ;
host_name_table (2) := (a_name, an_id) ;

a_name := a_blank_line ;
a_name(1..5) := "wicat" ;
an_id := 3 ;
host_name_table (3) := (a_name, an_id) ;

number_of_hosts := 3 ;

end xhost ;
--::::::::::::::
--unet_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01147-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         unet_.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package usmtp_network is
--
-- This package contains the usmtp interfaecs to the network transport
--   protocol process and other network-related functions.
--
--
procedure send_open_to_transport_layer(host_id : string) ;
--
-- Sends an open connection request to the transport layer.
--
--
procedure send_abort_to_transport ;
--
-- Sends an abort command to the transport layer to force termination
--  of a connection.
--
--
procedure send_string (str : in string) ;
--
-- formats an ascii string into the desired transport form and sends it
--   to the ssmtp
--
procedure send_close_to_transport_layer ;
--
-- Sends a close command to the transport layer to force a normal connection
--   close.
--
--

procedure get_reply (reply  : out string) ;
--
-- This procedure gets a reply string from the transport layer.
--  Converts transport layer format to string. Performs as many
--  transport layer reads as necessary until a complete response is found
--  (in case of multiline responses, etc.)
--

end usmtp_network ;


--::::::::::::::
--unet.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01148-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         unet.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------

with buffer_data ;           use buffer_data ;
with with_ulp_communicate ;  use with_ulp_communicate ;
with text_io;                use text_io ;
with usmtp_utils ;           use usmtp_utils ;
with xhost ;                 use xhost ;
with system ;                use system ;
--
package body usmtp_network is
--
-- Implementation for:    Vax 11/780
--                        tcp transport layer (esystesm version)
--                        dec ada
--
--
package int_io_32 is new integer_io(thirtytwo_bits) ;
package int_io_16 is new integer_io(sixteen_bits) ;
--
--
current_lcn : lcn_ptr_type ;  -- the lcn for the current open connection
--
--
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--
----
-- This is a local procedure to send a receive request to tcp
-- We should always have a few outstanding receives for tcp to put data into
--
procedure send_a_receive is
request_ok : boolean ;
tcp_params : with_ulp_communicate.message(receive) ;
a_buf      : packed_buffer_ptr ;
begin
buffget(a_buf,1) ;
if a_buf = null then
    put_line("Could not get a buffer") ;
    raise constraint_error ;   -- crash the connection
end if ;
tcp_params.receive_parameters.local_connection_name := current_lcn ;
tcp_params.receive_parameters.bufptr := a_buf ;
tcp_params.receive_parameters.byte_count := 190 ;
message_for_tcp(tcp_params,request_ok) ;
if not request_ok then
   raise constraint_error ;  -- crash the connection
end if ;
exception
  when others =>
    put_line("Exception in send_a_receive") ;
    raise ;
end send_a_receive ;

--
procedure send_string(str : in string) is
--
-- Given an ascii string, this procedure converts it to the
--  tcp format (byte array), formats a tcp send call, and calls the
--  tcp interface.
--
a_buffer   : packed_buffer_ptr ;
tcp_params : message(send) ;
send_block : send_params ;
request_ok : boolean ;

begin
  put("S: ") ;
  put_line(str) ;
  buffget(a_buffer, 0) ;
  -- patch for incorrect buffer spec
  --a_buffer.tcp_ptr := maximum_datagram_size - sixteen_bits(str'length) ;
  a_buffer.tcp_ptr := 254 - sixteen_bits(str'length) ;
  --- a_buffer.size := str'length ;  --- patch for tcp error :
  a_buffer.size := str'length + 1 ;  --- patch for tcp
  -- put the string bytes into the end of the buffer
  for i in 1..str'length loop
    a_buffer.byte(a_buffer.tcp_ptr + sixteen_bits(i))
        := character'pos(str(i)) ;
  end loop ;
  send_block.local_connection_name := current_lcn ;
  send_block.bufptr := a_buffer ;
  send_block.byte_count := a_buffer.size ;
  send_block.push_flag  := 0 ;
  send_block.urg_flag := 0 ;
  send_block.timeout  := 2000 ;
  tcp_params.send_parameters := send_block ;
  message_for_tcp(tcp_params,request_ok ) ;
  if not request_ok then
    raise tcp_reset ;
  end if ;
exception
  when tcp_reset =>
    put_line("TCP error in send_string") ;
    raise ;
  when others =>
    put_line("exception in send_string") ;
    raise ;
  end ;


--------------------------------------------------------------------------------
--------------------------------------------------------------------------------


procedure  send_abort_to_transport is
--
-- Format and send a tcp abort command to reset the connection.
-- May wait for connection_closed message from tcp.
--
tcp_params : message(abor_t) ;
reply : user_message ;
request_ok : boolean ;
begin
tcp_params.abort_close_parameters.local_connection_name := current_lcn ;
message_for_tcp(tcp_params,request_ok ) ;
if not request_ok then
  raise tcp_reset ;
end if ;
loop
reply.local_connection_name := current_lcn ;
wait_for_tcp_message (reply) ;
case reply.message_number is
  when 8 | 16 =>
    put_line("connection aborted") ;
    exit ;
  when others =>
    put("connection message") ;
    int_io_16.put(reply.message_number) ;
    new_line ;
  end case ;
end loop ;

exception
  when tcp_reset =>
    put_line("TCP error in send_abort_to_transport") ;
    raise ;
  when others =>
    put_line("exception in send_abort_to_transport ") ;
    raise ;
end ;



--------------------------------------------------------------------------------
--------------------------------------------------------------------------------


procedure send_to_transport(data_line : in string ) is
--
-- Call send_string to send a string.
--
begin
send_string(data_line) ;
exception
  when others =>
    put_line("exception in send_to_transport") ;
    raise ;
end ;


--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

procedure convert_to_lower_case (str : in out string) is
begin
 for i in 1..str'length loop
   if ( str(i) IN 'A'..'Z' ) then
     str(i) := character'val(character'pos(str(i)) + 32) ;
   end if ;
  end loop ;
end convert_to_lower_case ;


procedure send_open_to_transport_layer(host_id : string) is
--
-- Format a tcp_open and wait for connection_opened tcp response.
--
host_name_ok : boolean ;
host_addr    : buffer_data.thirtytwo_bits ;
tcp_params   : message(open) ;
reply        : user_message ;
request_ok   : boolean ;
id           : string (1..host_id'length) ;
begin
  id := host_id ;
  convert_to_lower_case(id) ;
  translate_host_name_to_address(id, host_addr, host_name_ok) ;
  if not host_name_ok then
    put_line("Bad host name") ;
    raise tcp_reset ;
  end if ;
  tcp_params.open_parameters.local_connection_name := current_lcn ;
  tcp_params.open_parameters.local_port := 26 ;
  tcp_params.open_parameters.foreign_net_host := host_addr ;
  tcp_params.open_parameters.foreign_port := 25 ;
  tcp_params.open_parameters.active_passive := active ;
  tcp_params.open_parameters.buffer_size := 0 ;
  tcp_params.open_parameters.timeout := 2000 ;
  tcp_params.open_parameters.security := 0 ;
  tcp_params.open_parameters.precedence := 0 ;
  tcp_params.open_parameters.options := (others => 0) ;
  message_for_tcp(tcp_params,request_ok ) ;
  current_lcn := tcp_params.open_parameters.local_connection_name ;
  if not request_ok then
    raise tcp_reset ;
  end if ;
  loop
    reply.local_connection_name := current_lcn ;
    wait_for_tcp_message (reply) ;
    case reply.message_number is
      when 23 =>
        exit ;
      when 14 =>
        current_lcn.lcn_ptr := reply.local_connection_name.lcn_ptr ;
      when 2 | 5 | 9 | 11 | 20 =>
        put("could not open, reason code = ") ;
        int_io_16.put(reply.message_number) ;
        put_line (" ." ) ;
        raise tcp_reset ;
      when 8 | 16 =>
        put_line("connection aborted") ;
        raise tcp_reset ;
      when others =>
        put("connection message") ;
        int_io_16.put(reply.message_number) ;
        new_line ;
      end case ;
  end loop ;
  send_a_receive ; -- leave an outstanding receive

exception
  when tcp_reset =>
    raise ;
  when others =>
    put_line("exception in send_open_to_transport ") ;
    raise ;
end send_open_to_transport_layer ;



--------------------------------------------------------------------------------
--------------------------------------------------------------------------------


procedure send_close_to_transport_layer is
--
-- Send a close command to tcp and wait for a connection_closed response.
--
tcp_params : message(close) ;
reply : user_message ;
request_ok : boolean ;
begin
tcp_params.abort_close_parameters.local_connection_name := current_lcn ;
message_for_tcp(tcp_params,request_ok ) ;
if not request_ok then
  raise tcp_reset ;
end if ;
loop
reply.local_connection_name := current_lcn ;
wait_for_tcp_message (reply) ;
case reply.message_number is
  when 8 | 16 =>
    put_line("connection aborted") ;
    exit ;
  when 6 | 18 =>    --&KJW 11-jul-85
    put_line("connection closed") ;
    exit ;
  when others =>
    put("connection message") ;
    int_io_16.put(reply.message_number) ;
    new_line ;
  end case ;
end loop ;
exception
  when tcp_reset =>
    put_line("TCP error in send_close") ;
    raise ;
  when others =>
    put_line("exception in send_close ") ;
    raise ;
end ;


--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

--
-- this procedure gets tcp data buffers until a reply  terminator is found
--
-- converts system.byte into ascii chars
-- keeps gathering characters until an end-of-reply (eor) is found.
-- an eor is indicated by a <crlf> if a single line reply or a
--  <crlf>.<crlf> if a multiline reply.
-- also separates the received data into the reply and any excess found in the
--  segment after the <crlf>. Note that there should not be anything
--  after the <crlf> if the server_smtp is ok.
--
-- all this is necessary because we cannot rely on the entire
--  reply being in a single tcp segment.
--
--    <reply_format>        = NNN<multiline_indicator>reply_text<eor>
--    <multiline_indicator> = <space> | -
--    <eor>                 = <crlf> | <crlf>.<crlf>
--
-- accepts all tcp messages
--  if tcp resets or closes  it will raise tcp_reset
--  tosses all others away
--

procedure process_data ( buf : packed_buffer_ptr;
                         str : out string ) is
str1 : string (1..str'length) := ( others =>  ' ') ;
len : integer ;
begin
len := integer(buf.telnet_ptr-buf.tcp_ptr);
for i in 1..len loop
  str1(i) := character'val(buf.byte(buf.tcp_ptr+sixteen_bits(i)-1) ) ;
end loop ;
put("R: ") ;
put_line(str1(1..len)) ;
str(1..3) := str1(1..3) ;
str(4..str'length) := (others => ' ') ;
end process_data ;

procedure get_reply (reply  : out string) is
  eor_found : boolean := false ;
  rep : string (1..80) ;           -- for debug
  erep : integer ;                 -- for debug
  reply_done : boolean := false ;
  tcp_reply : user_message ;
begin
reply(1..3) := "   " ;
while not reply_done loop
  tcp_reply.local_connection_name := current_lcn ;
  wait_for_tcp_message (tcp_reply) ;
  case tcp_reply.message_number is
  when 16 =>
    put_line("connection aborted") ;
    raise tcp_reset ;
  when 10 =>
    process_data (tcp_reply.data_buffer, reply) ;
    send_a_receive ;
    reply_done := true ;  -- single segment replies only!
  when others =>
    put("connection message") ;
    int_io_16.put(tcp_reply.message_number) ;
    new_line ;
  end case ;
end loop ;
exception
  when others =>
    put_line("exception in get_reply") ;
    raise ;
end get_reply ;


end usmtp_network ;
--::::::::::::::
--ucomm_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01143-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         ucomm_.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package usmtp_commands is
--
-- This package contains all the commands sent by the usmtp.
--
--
--
procedure send_data_to_server ;
--
-- Sends a DATA command to the ssmtp.
--
--
procedure send_rcpt_to_server(name : string) ;
--
-- Sends a RCPT command to the ssmtp.
--
--
procedure send_helo ;
--
-- Sends a HELO command to the ssmtp.
--
--
procedure send_mail (name : string) ;
--
-- Sends a MAIL command to the ssmtp.
--
--
procedure send_quit ;
--
-- Sends a QUIT command to the ssmtp.
--
--
procedure send_reset ;
--
-- Sends a RSET command to the ssmtp.
--
--
end usmtp_commands ;


--::::::::::::::
--ucomm.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01144-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         ucomm.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
with usmtp_utils ;       use usmtp_utils ;
with usmtp_network ;     use usmtp_network ;
with text_io ;           use text_io ;

package body usmtp_commands is
--
-- This package contains all the commands sent by the usmtp.
--
--
--
--
procedure send_data_to_server is
--
-- Send the DATA command to tcp.
--
begin
send_string("DATA") ;
exception
  when others =>
    put_line("exception in send_data_to_server") ;
    raise ;
end ;
--
--
--
procedure send_rcpt_to_server(name : string) is
--
-- Send the RCPT command to tcp. Formats the name into a proper command line
--  and calls send_string.
--
line : string (1..256) ;
len : integer ;
prep : string (1..9) := "RCPT to: " ;
begin
  len := name'length + prep'length ;
  line(1..len) := prep & name ;
  send_string(line (1..len));
exception
  when others =>
    put_line("exception in send_rcpt_to_server") ;
    raise ;
end send_rcpt_to_server ;



procedure  send_helo is
--
-- Send the HELO command to tcp. Formats the host name into a proper command
--  line and calls send_string.
-- To rehost, change my_host_name and recompile.
--
line : string (1..256) ;
len : integer ;
my_host_name : constant string(1..10)  := "ECI.SATURN" ;
begin
len := 5 + my_host_name'length ;
line(1..len) := "HELO " & my_host_name ;
send_string(line(1..len)) ;
exception
  when others =>
    put_line("exception in send_helo") ;
    raise ;
end send_helo ;
--
--
--
procedure send_mail (name : string) is
line : string (1..256) ;
len : integer ;
begin
len := 11 + name'length ;
line(1..len) := "MAIL from: " & name ;
send_string(line(1..len)) ;
exception
  when others =>
    put_line("exception in send_mail") ;
    raise ;
end send_mail ;
--
--
--
procedure send_quit is
begin
send_string("QUIT") ;
exception
  when others =>
    put_line("exception in send_quit") ;
    raise ;
end ;
--
--
--
procedure send_reset is
begin
send_string("RSET") ;
exception
  when others =>
    put_line("exception in send_reset ") ;
    raise ;
end ;
--
--
--
end usmtp_commands ;


--::::::::::::::
--uconn_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01145-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         uconn_.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package usmtp_connections is
--
-- This pacakge contains the connection related functions for the
--   communications with the ssmtp.
-- Allows opening connections, sending data, closing connections,
--    and forcing resets on connections.
--
--
--
procedure establish_connection_and_send_helo ;
--
-- This procedure performs the follwing functions:
--   1. request a transport connection to the well-known ssmtp network address
--   2. wait for the connection to be successfully opened
--   3. wait for a greeting reply from the ssmtp and print it
--   4. send a helo to the ssmtp
--   5. wait for a helo_ok reply from the ssmtp
--
-- If proper handshaking fails (connection not opened, incorrect reply
--   from ssmtp, etc.; this procedure queries the user for retries and loops
--   if requested. Exits with an excetpion if unsuccessful and no retry
--   requested.
--
-- raises the following exceptions:
--   abort_ssmtp if connection fails and user does not request retry
--
--
--
procedure close_smtp_connection ;
--
-- Sends a QUIT command to the ssmtp, waits for a proper reply, and
--  sends a close command to the transport layer for a normal connection
--  close.
--
--
--
end usmtp_connections ;

--::::::::::::::
--uconn.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01146-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         uconn.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------

with text_io;        use text_io ;
with usmtp_utils ;   use usmtp_utils ;
with usmtp_network;  use usmtp_network ;
with usmtp_commands; use usmtp_commands;

package body usmtp_connections is
--
-- Package implementation for :  Vax 11/780
--                               tcp transport service (esystems version)
--                               dec ada

procedure establish_connection_and_send_helo is
--
-- This procedure performs the follwing functions:
--   1. request a tcp connection to the well-known ssmtp socket
--   2. wait for a greeting reply (220) from the ssmtp and print it
--   3. send a helo to the ssmtp
--   4. wait for a helo_ok reply from the ssmtp
--
-- If proper handshaking fails (connection not opened, incorrect reply
--   from ssmtp, etc.; This procedure exits with an exception
--   if unsuccessful. Connection is closed if this occurs.
--
-- raises or propagates the following exceptions:
--   unexpected_reply if bad reply from ssmtp
--   smtp_error       if 4xx or 5xx from ssmtp
--   tcp reset        if connection lost or could not open
--
--

  host_name    : string (1..80) ;
  eol          : integer := 0 ;
  reply        : string (1..80) ;
begin
  put_line("Establish Connection to Remote Host ") ;
  put("enter remote host name -> ") ;
  get_line(host_name, eol) ;
  send_open_to_transport_layer(host_name(1..eol)) ;
  get_reply(reply) ;
  if reply(1..3) /= open_ok then
    put_line("Could not open...bad reply") ;
    put_line("Aborting connection") ;
    send_abort_to_transport ;
    raise tcp_reset ;
  else
    send_helo ;
    get_reply(reply) ;
    if reply(1..3) /= helo_ok then
      put_line("server not responding");
      put_line("Aborting connection") ;
      send_aborT_to_transport ;
      raise smtp_error ;
    end if ;
  end if ;
exception
  when smtp_error | tcp_reset =>
    raise ;
  when others =>
    put_line("unexpected exception in establish_connection_and_send_helo") ;
    raise ;
end establish_connection_and_send_helo;




procedure close_smtp_connection is
  reply : string(1..80) ;        --&KJW 11-jul-85;
begin
send_quit ;
get_reply(reply) ;            --&KJW 11-jul-85;
if reply(1..3) /= quit_ok then        --&KJW 11-jul-85;
  put_line("Quit reply not received") ;    --&KJW 11-jul-85;
  raise unexpected_reply ;        --&KJW 11-jul-85;
end if ;                --&KJW 11-jul-85;
send_close_to_transport_layer ;
exception
  when others =>
    put_line("exception in close_smtp_connection") ;
    raise ;
end close_smtp_connection ;



end usmtp_connections ;



--::::::::::::::
--utext_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01152-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         utext_.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package usmtp_text is
--
-- This package supports the mail data entry mode of usmtp.
--
procedure send_text ;
--
-- Continually get lines from the user and send them to the transport
--   layer until end-of-message is found.
--
end usmtp_text ;

--::::::::::::::
--utext.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01153-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         utext.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
with text_io;           use text_io ;
with usmtp_utils ;      use usmtp_utils ;
with usmtp_connections; use usmtp_connections ;
with usmtp_network ;    use usmtp_network ;
with usmtp_commands ;   use usmtp_commands ;
with usmtp_network ;    use usmtp_network ;


package body usmtp_text is


procedure send_text is
--
-- keep getting lines of data from the user and sending them to the transport
--   layer until an end-of-message is found.
--
-- Limitations:
--  Current end of message :  <CRLF>.<CRLF>
--  does not support mailing files.
--
  data_line : string(1..max_line_len) ;
  eol : natural ;
  reply : string(1..80) ;
  eof : boolean := false ;
  --&KJW 21-jul-85 end_mark : string (1..1) ;  -- could be a character if TS allowed it
begin
--&KJW 21-jul-85 end_mark(1) := '.' ;
send_data_to_server ;
get_reply(reply) ;
if reply(1..3) /= send_data_ok then
  put_line("server not responding") ;
  send_abort_to_transport ;
else
  put_line("Enter data. Terminate message with <CRLF>.<CRLF> ") ;
  while not eof loop
    get_line(data_line,eol) ;
    --&KJW 21-jul-85 if data_line(1..eol) = end_mark then
    --&KJW 21-jul-85   put_line("End of file found") ;
    --&KJW 21-jul-85   eof := true ;
    --&KJW 21-jul-85 elsif data_line(1..1) = "."  then
    --&KJW 21-jul-85   data_line := " " & data_line(1..79) ;
    --&KJW 21-jul-85   eol := eol + 1 ;
    --&KJW 21-jul-85 end if ;
    --&KJW 21-jul-85 send_string(data_line(1..eol)) ;
    if data_line(1) = '.' then            --&KJW 21-jul-85
      eof := eol = 1 ;                --&KJW 21-jul-85
      if eof then                --&KJW 21-jul-85
        send_string(".") ;            --&KJW 21-jul-85
      else                    --&KJW 21-jul-85
        send_string("." & data_line(1..eol)) ;    --&KJW 21-jul-85
      end if ;                    --&KJW 21-jul-85
    else                    --&KJW 21-jul-85
      send_string(data_line(1..eol)) ;        --&KJW 21-jul-85
    end if ;                    --&KJW 21-jul-85
  end loop ;
  get_reply(reply) ;
  if reply(1..3) /= data_ok then
    put_line ("server could not deliver") ;
  end if ;
end if ;
exception
  when others =>
    put_line("exception in send_text") ;
    raise ;
end  send_text ;

end usmtp_text ;
--::::::::::::::
--urcpt_.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01149-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         urcpt_.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
package usmtp_rcpt is
--
-- This package handles the recipient list mode.
--
procedure send_rcpt_list ;
--
-- Query the user for each recipient name in the list, send
--  the RCPT command, and wait for a response. Must receive
--  at least one rcpt_ok respone from the ssmtp before proceeding.
--
end usmtp_rcpt ;

--::::::::::::::
--urcpt.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01150-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         urcpt.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------

with text_io;           use text_io ;
with usmtp_utils ;      use usmtp_utils ;
with usmtp_connections; use usmtp_connections ;
with usmtp_commands;    use usmtp_commands;
with usmtp_network ;    use usmtp_network ;

package body usmtp_rcpt is

procedure send_rcpt_list is
--
-- For each recipient, query the user for the name and send it using
--   the send_rcpt procedure in usmtp_network.
-- Current limitations:
--   does not do any processing on user name strings
--   does not support local lists
--
--&KJW 21-jul-85 a_rcpt : boolean := false ;
rcpt_count : natural := 0 ;        --&KJW 21-jul-85
user_name : string (1..80) ;
eol : integer := 0 ;
reply : string (1..80) ;
begin
  put_line("Enter rcpt list 1 at a time ... nul line to terminate list") ;
  loop
    put ("To: ") ;
    get_line(user_name,eol);
    if eol /= 0 then
      send_rcpt_to_server(user_name(1..eol)) ;
      get_reply(reply) ;
      --&KJW 18-jul-85 if reply(1..3) = rcpt_ok then
      --&KJW 18-jul-85   put_line ("rcpt ok") ;
      --&KJW 18-jul-85   a_rcpt := true ;
      --&KJW 18-jul-85 else
      --&KJW 18-jul-85   put_line("rcpt not ok") ;
      --&KJW 18-jul-85 end if ;
      --&KJW 21-jul-85 a_rcpt := reply(1..3) = rcpt_ok ;--&KJW 18-jul-85
      if reply(1..3) = rcpt_ok then    --&KJW 21-jul-85
        rcpt_count := rcpt_count + 1 ;    --&KJW 21-jul-85
      end if ;                --&KJW 21-jul-85
    else
      --&KJW 21-jul-85 if not a_rcpt then
      if rcpt_count < 1 then        --&KJW 21-jul-85
        put_line ("Must enter at least one rcpt") ;
      else
        exit ;
      end if ;
    end if ;
  end loop ;
exception
  when others =>
    put_line("exception in send_rcpt_list") ;
    raise ;
end send_rcpt_list ;


end usmtp_rcpt ;
--::::::::::::::
--usmtp.ada
--::::::::::::::
-----------------------------------------------------------------------
--
--         DoD Protocols    NA-00006-200       80-01151-100(-)
--         E-Systems, Inc.  August 07, 1985
--
--         usmtp.ada       Author : Paul Higgins
--
-----------------------------------------------------------------------
with text_io;             use text_io ;
with usmtp_utils ;        use usmtp_utils ;
with usmtp_connections;   use usmtp_connections ;
with usmtp_network ;      use usmtp_network ;
with usmtp_rcpt ;         use usmtp_rcpt ;
with usmtp_text ;         use usmtp_text ;
with usmtp_commands ;     use usmtp_commands ;
with buffer_data ;        use buffer_data ;

procedure usmtp is

name        : string (1..255) ;
name_length : integer ;
continue    : string (1..255) := ('y', others => ' ') ;
len         : integer ;
reply       : string(1..80) ;

begin
put_line ("SMTP ver 1.0") ;
buffer_data.init ;
while continue(1) = 'y' loop
  begin
  establish_connection_and_send_helo ;
  put("Enter sender's name -> ");
  get_line(name,name_length) ;
  send_mail(name(1..name_length));
  get_reply(reply) ;
  if reply(1..3) /= helo_ok then
    put_line("Mail reply not received") ;
    raise unexpected_reply ;
  end if ;
  while continue(1) = 'y' loop
    send_rcpt_list ;
    send_text ;
    put_line("Any more mail for this host (y for yes)? " ) ;
    get_line(continue,len) ;
  end loop ;
--&KJW 11-jul-85 send_quit ;
--&KJW 11-jul-85 send_close_to_transport_layer ;
close_smtp_connection ;    --&KJW 11-jul-85
exception
  when abort_usmtp =>
    put_line(" Exit SMTP ") ;
    raise ;
  when smtp_error =>
    put_line(" server replies error in transmission... connection aborted ") ;
  when unexpected_reply =>
    put_line(" error in server - unexpected reply... connection aborted ") ;
  when tcp_reset =>
    put_line(" error in tcp transmission... connection aborted ") ;
  when others =>
    put_line ("unknown exception in smtp... exiting") ;
    raise ;
  end ;
put_line("Any more mail to send  (y for yes)? " ) ;
get_line(continue,len) ;
end loop ;
put_line(" Exit SMTP ") ;
exception
  when others =>
    put_line("enter ctrl-c to terminate all tasks...") ;
end usmtp ;