Patch title: Release 94 bulk changes
Abstract:
File: /pliant/protocol/smtp/client.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program 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 General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

module "/pliant/language/unsafe.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/multi.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/language/stream/openmode.pli"
module "/pliant/language/stream/flushmode.pli"
module "/pliant/fullpliant/this_computer.pli"
module "/pliant/protocol/dns/client.pli"

constant extended false
constant default_timeout 300
constant trace false

(gvar TraceSlot smtp_trace) configure "SMTP client"


if extended

  function command s cmd extra log -> c
    arg_rw Stream s ; arg Str cmd ; arg_w Str extra ; arg_rw TraceSession log ; arg Int c
    if cmd<>""
      s writeline cmd
      log trace "query " cmd
    var Str l := s readline  
    log trace "answer " l
    if s=failure
      return 599
    extra := ""
    while (l parse c "-" any:(var Str remain))
      l := s readline
      log trace "answer " l
      if (l parse c _ any:(var Str remain)) or (l parse c _ any:(var Str remain))
        extra += " "+remain
    if not (l parse c _ any:(var Str remain))
      return 598

  function command s cmd log -> c
    arg_rw Stream s ; arg Str cmd ; arg_rw TraceSession log ; arg Int c
    c := command s cmd (var Str extra) log

else

  function command s cmd log -> c
    arg_rw Stream s ; arg Str cmd ; arg_rw TraceSession log ; arg Int c
    if cmd<>""
      if trace
        console "-> " cmd eol
      s writeline cmd
      log trace "query " cmd
    var Str l := s readline  
    var Str l := s readline
    if trace
      console "<- " l eol
    log trace "answer " l
    if s=failure
      return 599
    while (l parse c "-" any:(var Str remain))
      l := s readline
      if trace
        console "<- " l eol
      log trace "answer " l
    if not (l parse c _ any:(var Str remain))
      return 598
 

type SmtpFileSystem
  void
FileSystem maybe SmtpFileSystem

type SmtpStreamDriver
  field Link:Stream tcp
  field Link:TraceSession log
StreamDriver maybe SmtpStreamDriver

method smtp write buf mini maxi -> written
  arg_rw SmtpStreamDriver smtp ; arg Address buf ; arg Int mini maxi written
  written := smtp:tcp:stream_driver write buf mini maxi

method smtp flush level -> status
  arg_rw SmtpStreamDriver smtp ; arg Int level ; arg Status status
  status := smtp:tcp:stream_driver flush level

method smtp close -> status
  arg_rw SmtpStreamDriver smtp ; arg ExtendedStatus status
  status := success
  if (command smtp:tcp "." smtp:log)>=300
    status := failure
  if (command smtp:tcp "QUIT" smtp:log)>=300
    status := failure
  smtp:tcp flush end
  if smtp:tcp=failure
    status := failure
  smtp:tcp close

method smtp query command stream answer -> status
  arg_rw SmtpStreamDriver smtp ; arg Str command ; arg_rw Stream stream ; arg_w Str answer ; arg ExtendedStatus status 
  status := smtp:tcp:stream_driver query command smtp:tcp answer

method smtp configure command stream -> status
  arg_rw SmtpStreamDriver smtp ; arg Str command ; arg_rw Stream stream ; arg ExtendedStatus status
  status := smtp:tcp:stream_driver configure command smtp:tcp

function conforming_name n -> c
  arg Str n c
  if not (n parse any "<" any:(var Str m) ">" any)
    n parse any:m
  c := "<"+m+">"

method fs open name options flags stream support -> status
  arg_rw SmtpFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
  var DateTime dt := datetime
  if (flags .and. in_out)<>out
    return failure
  var Link:Stream tcp :> new Stream
  var Str servers := options option "server" Str
  if servers="" and ( (name parse any "@" any:(var Str domain) ">" any) or (name parse any "@" any:(var Str domain) "(" any) or (name parse any "@" any:(var Str domain)) )
    var Str servers := dns_query domain 15
    if servers=""
      servers := dns_query domain 1
  if servers="" 
    servers := this_computer:env:"pliant":"mail":"smtp_provider"
  part connect
    while tcp=failure and servers<>""
      if not (servers parse any:(var Str server) _ any:(var Str remain))
        server := servers ; remain := ""
      tcp open "tcp:"+(shunt server<>"" "//"+server "")+"/client/25" in+out+cr+lf+safe
      servers := remain
  if tcp=failure
    if trace
      console "Failed to open channel " tcp:name eol
    smtp_trace trace "Failed to open channel " tcp:name
    return failure
  tcp configure "timeout "+string:(options option "timeout" Int default_timeout)
  var Link:TraceSession log :> new TraceSession
  log bind smtp_trace
  if (command tcp "" log)>=300
    return failure
  var Str myname := options option "myname" Str
  if myname="" and computer_name<>"" and computer_domain<>""
    myname := computer_name+"."+computer_domain
  if myname=""
    myname := tcp query "local_ip_address"
  if extended
    var Str capabilities
    if (command tcp "EHLO "+myname capabilities log)>=300
      if (command tcp "HELO "+myname log)>=300
        return failure
  else
    if (command tcp "HELO "+myname log)>=300
      return failure
  var Str from := options option "from" Str
  if from<>""
    if (command tcp "MAIL FROM:"+conforming_name:from log)>=300
      return failure
  var Str to := name
  if to<>""
    if (command tcp "RCPT TO:"+conforming_name:to log)>=300
      return failure
  var Int i := 0
  while { var Str to2 := options option "to" i Str ; to2<>"" }
    if (command tcp "RCPT TO:"+conforming_name:to2 log)>=300
      return failure
    i += 1
  var Int i := 0
  while { var Str to2 := options option "cc" i Str ; to2<>"" }
    if (command tcp "RCPT TO:"+conforming_name:to2 log)>=300
      return failure
    i += 1
  status := success
  var Int i := 0
  while { var Str file := options option "mailing" i Str ; file<>"" }
    (var Stream mailing) open file in+safe
    while not mailing:atend
      var Str l := mailing readline
      if not l:parse
        if (command tcp "RCPT TO:"+conforming_name:l log)>=300
          status := failure
    mailing close
    i += 1
  if (command tcp "DATA" log)>=400
    return failure
  if not (options option "noheader")
    tcp writeline "Date: "+("SunMonTueWedThuFriSat" dt:day_of_week*3 3)+", "+(string dt:day)+" "+("JanFebMarAprMayJunJulAugSepOctNovDec" 3*dt:month-3 3)+" "+(right (string dt:year) 4 "0")+" "+(right (string dt:hour) 2 "0")+":"+(right (string dt:minute) 2 "0")+":"+(right (string dt:second) 2 "0")+" +0000"
    if from<>""
      tcp writeline "From: "+from
    if to<>""
      tcp writeline "To: "+to
    var Int i := 0
    while { var Str to2 := options option "to" i Str ; to2<>"" }
      tcp writeline "To: "+to2
      i += 1
    var Int i := 0
    while { var Str to2 := options option "cc" i Str ; to2<>"" }
      tcp writeline "CC: "+to2
      i += 1
    var Str subject := options option "subject" Str
    if subject<>""
      tcp writeline "Subject: "+subject
    var Str references := options option "references" Str
    if references<>""
      tcp writeline "References: "+references
    var Str mime := options option "mime" Str
    if mime<>""
      tcp writeline "Content-Type: "+mime
    tcp writeline ""
  tcp flush anytime
  var Link:SmtpStreamDriver smtp :> new SmtpStreamDriver
  smtp tcp :> tcp
  smtp log :> log
  stream stream_driver :> smtp
  stream stream_flags := stream:stream_flags .or. cr+lf


gvar SmtpFileSystem smtp_file_system
pliant_multi_file_system mount "smtp:" "" smtp_file_system