/pliant/protocol/smtp/client.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  module "/pliant/language/unsafe.pli" 
 17  module "/pliant/language/context.pli" 
 18  module "/pliant/language/stream.pli" 
 19  module "/pliant/language/stream/multi.pli" 
 20  module "/pliant/language/stream/filesystembase.pli" 
 21  module "/pliant/language/stream/openmode.pli" 
 22  module "/pliant/language/stream/flushmode.pli" 
 23  module "/pliant/fullpliant/this_computer.pli" 
 24  module "/pliant/protocol/dns/client.pli" 
 25   
 26  constant extended false 
 27  constant default_timeout 300 
 28  constant trace false 
 29   
 30  (gvar TraceSlot smtp_trace) configure "SMTP client" 
 31   
 32   
 33  if extended 
 34   
 35    function command s cmd extra log -> c 
 36      arg_rw Stream s ; arg Str cmd ; arg_w Str extra ; arg_rw TraceSession log ; arg Int c 
 37      if cmd<>"" 
 38        s writeline cmd 
 39        log trace "query " cmd 
 40      var Str l := s readline   
 41      log trace "answer " l 
 42      if s=failure 
 43        return 599 
 44      extra := "" 
 45      while (l parse c "-" any:(var Str remain)) 
 46        l := s readline 
 47        log trace "answer " l 
 48        if (l parse c _ any:(var Str remain)) or (l parse c _ any:(var Str remain)) 
 49          extra += " "+remain 
 50      if not (l parse c _ any:(var Str remain)) 
 51        return 598 
 52   
 53    function command s cmd log -> c 
 54      arg_rw Stream s ; arg Str cmd ; arg_rw TraceSession log ; arg Int c 
 55      c := command s cmd (var Str extra) log 
 56   
 57  else 
 58   
 59    function command s cmd log -> c 
 60      arg_rw Stream s ; arg Str cmd ; arg_rw TraceSession log ; arg Int c 
 61      if cmd<>"" 
 62        if trace 
 63          console "-> " cmd eol 
 64        s writeline cmd 
 65        log trace "query " cmd 
 66      var Str l := s readline 
 67      if trace 
 68        console "<- " l eol 
 69      log trace "answer " l 
 70      if s=failure 
 71        return 599 
 72      while (l parse c "-" any:(var Str remain)) 
 73        l := s readline 
 74        if trace 
 75          console "<- " l eol 
 76        log trace "answer " l 
 77      if not (l parse c _ any:(var Str remain)) 
 78        return 598 
 79    
 80   
 81  type SmtpFileSystem 
 82    void 
 83  FileSystem maybe SmtpFileSystem 
 84   
 85  type SmtpStreamDriver 
 86    field Link:Stream tcp 
 87    field Link:TraceSession log 
 88  StreamDriver maybe SmtpStreamDriver 
 89   
 90  method smtp write buf mini maxi -> written 
 91    arg_rw SmtpStreamDriver smtp ; arg Address buf ; arg Int mini maxi written 
 92    written := smtp:tcp:stream_driver write buf mini maxi 
 93   
 94  method smtp flush level -> status 
 95    arg_rw SmtpStreamDriver smtp ; arg Int level ; arg Status status 
 96    status := smtp:tcp:stream_driver flush level 
 97   
 98  method smtp close -> status 
 99    arg_rw SmtpStreamDriver smtp ; arg ExtendedStatus status 
 100    status := success 
 101    if (command smtp:tcp "." smtp:log)>=300 
 102      status := failure 
 103    if (command smtp:tcp "QUIT" smtp:log)>=300 
 104      status := failure 
 105    smtp:tcp flush end 
 106    if smtp:tcp=failure 
 107      status := failure 
 108    smtp:tcp close 
 109   
 110  method smtp query command stream answer -> status 
 111    arg_rw SmtpStreamDriver smtp ; arg Str command ; arg_rw Stream stream ; arg_w Str answer ; arg ExtendedStatus status  
 112    status := smtp:tcp:stream_driver query command smtp:tcp answer 
 113   
 114  method smtp configure command stream -> status 
 115    arg_rw SmtpStreamDriver smtp ; arg Str command ; arg_rw Stream stream ; arg ExtendedStatus status 
 116    status := smtp:tcp:stream_driver configure command smtp:tcp 
 117   
 118  function conforming_name n -> c 
 119    arg Str n c 
 120    if not (n parse any "<" any:(var Str m) ">" any) 
 121      n parse any:m 
 122    c := "<"+m+">" 
 123   
 124  method fs open name options flags stream support -> status 
 125    arg_rw SmtpFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status 
 126    var DateTime dt := datetime 
 127    if (flags .and. in_out)<>out 
 128      return failure 
 129    var Link:Stream tcp :> new Stream 
 130    var Str servers := options option "server" Str 
 131    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)) ) 
 132      var Str servers := dns_query domain 15 
 133      if servers="" 
 134        servers := dns_query domain 1 
 135    if servers=""  
 136      servers := this_computer:env:"pliant":"mail":"smtp_provider" 
 137    part connect 
 138      while tcp=failure and servers<>"" 
 139        if not (servers parse any:(var Str server) _ any:(var Str remain)) 
 140          server := servers ; remain := "" 
 141        tcp open "tcp:"+(shunt server<>"" "//"+server "")+"/client/25" in+out+cr+lf+safe 
 142        servers := remain 
 143    if tcp=failure 
 144      if trace 
 145        console "Failed to open channel " tcp:name eol 
 146      smtp_trace trace "Failed to open channel " tcp:name 
 147      return failure 
 148    tcp configure "timeout "+string:(options option "timeout" Int default_timeout) 
 149    var Link:TraceSession log :> new TraceSession 
 150    log bind smtp_trace 
 151    if (command tcp "" log)>=300 
 152      return failure 
 153    var Str myname := options option "myname" Str 
 154    if myname="" and computer_name<>"" and computer_domain<>"" 
 155      myname := computer_name+"."+computer_domain 
 156    if myname="" 
 157      myname := tcp query "local_ip_address" 
 158    if extended 
 159      var Str capabilities 
 160      if (command tcp "EHLO "+myname capabilities log)>=300 
 161        if (command tcp "HELO "+myname log)>=300 
 162          return failure 
 163    else 
 164      if (command tcp "HELO "+myname log)>=300 
 165        return failure 
 166    var Str from := options option "from" Str 
 167    if from<>"" 
 168      if (command tcp "MAIL FROM:"+conforming_name:from log)>=300 
 169        return failure 
 170    var Str to := name 
 171    if to<>"" 
 172      if (command tcp "RCPT TO:"+conforming_name:to log)>=300 
 173        return failure 
 174    var Int i := 0 
 175    while { var Str to2 := options option "to" i Str ; to2<>"" } 
 176      if (command tcp "RCPT TO:"+conforming_name:to2 log)>=300 
 177        return failure 
 178      i += 1 
 179    var Int i := 0 
 180    while { var Str to2 := options option "cc" i Str ; to2<>"" } 
 181      if (command tcp "RCPT TO:"+conforming_name:to2 log)>=300 
 182        return failure 
 183      i += 1 
 184    status := success 
 185    var Int i := 0 
 186    while { var Str file := options option "mailing" i Str ; file<>"" } 
 187      (var Stream mailing) open file in+safe 
 188      while not mailing:atend 
 189        var Str l := mailing readline 
 190        if not l:parse 
 191          if (command tcp "RCPT TO:"+conforming_name:l log)>=300 
 192            status := failure 
 193      mailing close 
 194      i += 1 
 195    if (command tcp "DATA" log)>=400 
 196      return failure 
 197    if not (options option "noheader") 
 198      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" 
 199      if from<>"" 
 200        tcp writeline "From: "+from 
 201      if to<>"" 
 202        tcp writeline "To: "+to 
 203      var Int i := 0 
 204      while { var Str to2 := options option "to" i Str ; to2<>"" } 
 205        tcp writeline "To: "+to2 
 206        i += 1 
 207      var Int i := 0 
 208      while { var Str to2 := options option "cc" i Str ; to2<>"" } 
 209        tcp writeline "CC: "+to2 
 210        i += 1 
 211      var Str subject := options option "subject" Str 
 212      if subject<>"" 
 213        tcp writeline "Subject: "+subject 
 214      var Str references := options option "references" Str 
 215      if references<>"" 
 216        tcp writeline "References: "+references 
 217      var Str mime := options option "mime" Str 
 218      if mime<>"" 
 219        tcp writeline "Content-Type: "+mime 
 220      tcp writeline "" 
 221    tcp flush anytime 
 222    var Link:SmtpStreamDriver smtp :> new SmtpStreamDriver 
 223    smtp tcp :> tcp 
 224    smtp log :> log 
 225    stream stream_driver :> smtp 
 226    stream stream_flags := stream:stream_flags .or. cr+lf 
 227   
 228   
 229  gvar SmtpFileSystem smtp_file_system 
 230  pliant_multi_file_system mount "smtp:" "" smtp_file_system 
 231