Patch title: Release 94 bulk changes
Abstract:
File: /pliant/protocol/smtp/forward.pli
Key:
    Removed line
    Added line
abstract
  [The 'forward_message' function will attempt to forward a mail to the next SMTP server.]

# 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/compiler.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/context.pli"
module "/pliant/fullpliant/this_computer.pli"
module "/pliant/appli/database.pli"
module "/pliant/storage/database.pli"
module "/pliant/admin/file.pli"
module "mail.pli"
module "meta.pli"
module "/pliant/protocol/dns/client.pli"
module "/pliant/language/schedule/namedsem.pli"
module "/pliant/language/schedule/resourcesem.pli"
module "/pliant/language/schedule/daemon.pli"

constant verbose true
constant forward_timeout 300

gvar NamedSem forward_sem
public
  (gvar ResourceSem forward_immediat) configure 16

(gvar TraceSlot forward_trace) configure "SMTP forwarder"


#-------------------------------------------------------------------------


function forward_path mailto route -> computers
  arg Str mailto route computers
  if not (mailto parse any "<" any:(var Str to) ">" any)
    mailto parse any:to
  var Data:MailBox box :> mailbox to
  if exists:box
    return box:computer
  box :> mailbox lower:to
  if exists:box
    return box:computer
  if route<>""
    return route
  computers := this_computer:env:"pliant":"mail":"forward_route"
  if computers<>""
    return
  var Str domain := to (to search "@" -1)+1 to:len
  computers := dns_query domain 15
  if computers=""
    computers := dns_query domain 1


#-------------------------------------------------------------------------


function backward_mail filename -> status
  arg Str filename ; arg Status status
  forward_trace trace "backwarding " filename
  var (Link Database:MailMeta) db :> new Database:MailMeta
  db load (replace filename ".mail" ".pdb")
  var Data:MailMeta meta :> db data
  if meta:from=""
    file_delete filename
    file_delete (replace filename ".mail" ".pdb")
    file_directory_flush filename
    file_hook filename
    file_hook (replace filename ".mail" ".pdb")
    return
  (var Stream dest) open (replace filename ".mail" ".tmp") out+safe
  dest writeline "Subject: Mail delivery failure"
  dest writeline "To: "+meta:from
  dest writeline ""
  each target meta:target
    if target:status<>"S"
      dest writeline "Could not send the mail to "+target:box
      dest writeline "Tryed "+(string target:try_count)+" times."
      dest writeline "At the last try, on "+(string target:last_server)
      dest writeline "SMTP server '"+target:last_server+"' reported the following"+(shunt target:status="R" " fatal" "")+" error:"
      dest writeline target:last_error
      dest writeline ""
  dest writeline "The beginning of the mail was: "
  (var Stream src) open filename in+safe
  while not src:atend and src:line_number<60
    dest writeline src:readline
  src close ; dest close
  var Str from := meta from
  data_reset meta
  meta:target create ""
  meta:target:"":box := from
  db store
  file_delete filename ; file_move (replace filename ".mail" ".tmp") filename
  file_directory_flush filename
  file_hook filename

  
function command s cmd answer log -> c
  arg_rw Stream s ; arg Str cmd ; arg_w Str answer ; arg_rw TraceSession log ; arg Int c
  if cmd<>""
    s writeline cmd
    log trace "query " cmd
  answer := s readline  
  log trace "answer " answer
  if s=failure
    return 458
  while (answer parse c "-" any)
    answer := s readline
    log trace "answer " answer
  if not (answer parse c _ any)
    return (shunt answer="" 459 509)

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

function command s cmd comment msg fatal log -> escape
  arg_rw Stream s ; arg Str cmd comment ; arg_rw Str msg ; arg_rw CBool fatal ; arg_rw TraceSession log ; arg CBool escape
  var Int err := command s cmd  (var Str answer) log
  escape := err>=400
  if escape
    msg := comment+": "+answer
    if err>=500
      fatal := true

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+">"


function forward_to_server filename meta server target -> status
  arg Str filename ; arg_rw Data:MailMeta meta ; arg Str server ; arg_rw Data:MailMetaTarget target ; arg Status status
  (var TraceSession log) bind forward_trace
  log trace "forwarding " filename " to " server
  var CBool direct := meta direct
  var Str route := meta route
  var List:Str ontheway
  if exists:target
    ontheway += keyof target
  else
    each t meta:target
      if t:status=" "
        part scan_computers
          var Str computers := forward_path t:box route
          while computers<>""
            if not (computers parse any:(var Str computer) _ any:(var Str remain))
              computer := computers ; remain := ""
            if computer=server
              ontheway += keyof t
              leave scan_computers
            if direct
              leave scan_computers
            computers := remain
  var DateTime timestamp := datetime
  var Pointer:Str id :> ontheway first
  while exists:id
    var Data:MailMetaTarget t :> meta:target:id
    t try_count += 1
    t last_try := timestamp
    t last_server := server
    t last_error := "sending"
    id :> ontheway next id
  status := failure
  var CBool some := false ; var Str msg := "Pliant internal bug" ; var CBool fatal := false
  part talk
    var Str ip := dns_query server 1
    if ip=""
      log trace "could not find IP address of " server
      msg := "could not find IP address of "+server
      leave talk
    (var Stream tcp) open "tcp://"+ip+"/client/25" in+out+safe+cr+lf
    if tcp=failure
      log trace "failed to connect to " server " SMTP TCP port"
      msg := "failed to connect to "+server+" SMTP TCP port"
      leave talk
    tcp configure "priority low"
    tcp configure "timeout "+string:forward_timeout
    if (command tcp "" "server did not welcome us" msg fatal log)
      leave talk
    var Str smtp_name := this_computer:env:"pliant":"mail":"smtp_name"
    if smtp_name=""
      smtp_name := computer_fullname 
    if (command tcp "HELO "+smtp_name "server rejected our greeting" msg fatal log)
      leave talk
    if meta:from<>""
      if (command tcp "MAIL FROM:"+(conforming_name meta:from) "server rejected our from specification" msg fatal log)
        leave talk
    var Pointer:Str id :> ontheway first
    while exists:id
      var Data:MailMetaTarget t :> meta:target:id
      var Int err := command tcp "RCPT TO:"+(conforming_name t:box) (var Str answer) log
      if err<300
        some := true
      else
        t last_error := shunt (answer parse word:"sending" any) "- "+answer+" -" answer
        if err>=500
          t status := "R"
      id :> ontheway next id
    if not some
      msg := "no recipient for the message."
      leave talk
    if (command tcp "DATA" "server rejected the mail (at beginning)" msg fatal log)
      leave talk
    if exists:target
      tcp writeline "To: "+target:box
    if verbose
      var Intn total := (file_query filename standard) size
    (var Stream mail) open filename in+safe
    while not mail:atend
      var Str l := mail readline
      if (l 0 1)="."
        l := "."+l
      tcp writeline l
      if verbose and (mail:line_number .and. 255)=1
        if ((mail query "seek") parse (var Intn offset))
          var Pointer:Str id :> ontheway first
          while exists:id
            var Data:MailMetaTarget t :> meta:target:id
            if (t:last_error parse word:"sending" any)
              t last_error := "sending "+string:(cast 100*offset\total Int)+"%"
            id :> ontheway next id
    if (command tcp "." "server rejected the mail (at end)" msg fatal log)
      leave talk
    command tcp "QUIT" log
    status := success
  tcp close
  var Pointer:Str id :> ontheway first
  while exists:id
    var Data:MailMetaTarget t :> meta:target:id
    if (t:last_error parse word:"sending" any)
      if status=success
        t status := "S"
        t last_error := ""
      else
        t last_error := msg
    if fatal
      t status := "R"
    id :> ontheway next id


function forward_mail filename -> status
  arg Str filename ; arg Status status
  forward_sem request filename
  part do_forward "forwarding mail "+filename
    if (file_query filename standard)=defined
      forward_trace trace "forwarding " filename
      var (Link Database:MailMeta) db :> new Database:MailMeta
      db load (replace filename ".mail" ".pdb")
      var Data:MailMeta meta :> db data
      var CBool split := meta split
      var CBool direct := meta direct
      var Str route := meta route
      if split and meta:threads>1
        parallel threads meta:threads
          each t meta:target
            if t:status=" " and not daemon_emergency
              task
                part forward_to_one
                  var Str computers := forward_path t:box route
                  if computers=""
                    forward_trace trace "no mail server or wrong domain for " t:box
                    t try_count += 1
                    t last_try := datetime
                    t last_server := ""
                    t last_error := "no mail server or wrong domain"
                  while computers<>""
                    if not (computers parse any:(var Str computer) _ any:(var Str remain))
                      computer := computers ; remain := ""
                    if (forward_to_server filename meta computer t)=success
                      leave forward_to_one
                    if direct
                      leave forward_to_one
                    computers := remain
      else
        var (Dictionary Str Void) tryed
        each t meta:target
          part forward_to_one
            if t:status<>" " or daemon_emergency
              leave forward_to_one
            var Str computers := forward_path t:box route
            if computers=""
              forward_trace trace "no mail server or wrong domain for " t:box
              t try_count += 1
              t last_try := datetime
              t last_server := ""
              t last_error := "no mail server or wrong domain"
            while computers<>""
              if not (computers parse any:(var Str computer) _ any:(var Str remain))
                computer := computers ; remain := ""
              if split
                if (forward_to_server filename meta computer t)=success
                  leave forward_to_one
              else
                if not exists:(tryed first computer)
                  tryed insert computer void
                  if (forward_to_server filename meta computer (var Data:MailMetaTarget empty_target))=success
                    leave forward_to_one
              if direct
                leave forward_to_one
              computers := remain
      status := success ; var Int success_count := 0 ; var Int total_count := 0
      var CBool try_again := datetime:seconds-meta:queued_on:seconds<meta:try_period
      each t meta:target
        if t:status<>"S"
          status := failure
          if t:status=" " and t:try_count<meta:try_times
            try_again := true
        else
          success_count += 1
        total_count += 1
      db store
      var CBool surrender := not try_again and not meta:report
      var CBool removed := (file_query filename standard)=undefined
      if status=success or surrender or removed
        forward_trace trace "removing " filename+" (forwarded "+string:success_count+"/"+string:total_count+(shunt surrender " surrender" "")+(shunt removed " removed" "")+")"
        file_delete filename
        file_delete (replace filename ".mail" ".pdb")
        file_directory_flush filename
        file_hook filename
        file_hook (replace filename ".mail" ".pdb")
      eif not try_again
        backward_mail filename
  forward_sem release filename

function forward_mail filename detached action -> status
  arg Str filename ; arg CBool detached ; arg Str action ; arg Status status
  if (forward_immediat nowait_request 1)
    if detached
      status := success
      safe
        thread
          part async_forward action
            forward_mail filename
          forward_immediat release 1
      failure
        forward_immediat release 1
        status := failure
    else
      part sync_forward action
        status := forward_mail filename
      forward_immediat release 1
  else
    forward_trace trace "fowarding delayed because all forwarding slots are currently in use"
  

function forward_path filename route options
  arg Str filename ; arg Str route options
  forward_sem request filename
  if (file_query filename standard)=defined
    var (Link Database:MailMeta) db :> new Database:MailMeta
    db load (replace filename ".mail" ".pdb")
    db:data route := route
    if (options option "direct")
      db:data direct := true
    if (options option "indirect")
      db:data direct := false
    if (options option "split")
      db:data direct := true
    if (options option "group")
      db:data direct := false
    db store
  forward_sem release filename


#-------------------------------------------------------------------------


function forward_mails
  if (this_computer:env:"pliant":"mail":"forward_immediat" parse (var Int n))
    forward_immediat configure n
  daemon "mails forwarder daemon"
    var CBool again := true
    while again and not daemon_emergency
      again := false
      if not (this_computer:env:"pliant":"mail":"forward_sleep" parse (var Float f))
        f := 3600
      daemon_sleep f
      if not daemon_emergency
        var (Dictionary Str CBool) done_path := var (Dictionary Str CBool) empty_dictionary
        if not (this_computer:env:"pliant":"mail":"forward_threads" parse (var Int n))
          n := 1
        parallel threads n
          each box mailbox
            var Str path
            if box:computer=computer_fullname
              path := box out_path
            eif box:relay_computer=computer_fullname
              path := box relay_path
            else
              path := ""
            if path<>"" and not exists:(done_path first path) and pliant_execution_phase<=execution_phase_run
              done_path insert path true
              var Array:FileInfo files := file_list path standard
              for (var Int i) 0 files:size-1
                if files:i:extension=".mail" and not daemon_emergency
                  again := true
                  var Str name := files:i name
                  task
                    forward_mail name

forward_mails


export forward_mail forward_mails forward_path