/pliant/protocol/smtp/forward.pli
 
 1  abstract 
 2    [The 'forward_message' function will attempt to forward a mail to the next SMTP server.] 
 3   
 4  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 5  # 
 6  # This program is free software; you can redistribute it and/or 
 7  # modify it under the terms of the GNU General Public License version 2 
 8  # as published by the Free Software Foundation. 
 9  # 
 10  # This program is distributed in the hope that it will be useful, 
 11  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 12  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 13  # GNU General Public License for more details. 
 14  # 
 15  # You should have received a copy of the GNU General Public License 
 16  # version 2 along with this program; if not, write to the Free Software 
 17  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 18   
 19  module "/pliant/language/compiler.pli" 
 20  module "/pliant/language/stream.pli" 
 21  module "/pliant/language/context.pli" 
 22  module "/pliant/fullpliant/this_computer.pli" 
 23  module "/pliant/storage/database.pli" 
 24  module "/pliant/admin/file.pli" 
 25  module "mail.pli" 
 26  module "meta.pli" 
 27  module "/pliant/protocol/dns/client.pli" 
 28  module "/pliant/language/schedule/namedsem.pli" 
 29  module "/pliant/language/schedule/resourcesem.pli" 
 30  module "/pliant/language/schedule/daemon.pli" 
 31   
 32  constant verbose true 
 33  constant forward_timeout 300 
 34   
 35  gvar NamedSem forward_sem 
 36  public 
 37    (gvar ResourceSem forward_immediat) configure 16 
 38   
 39  (gvar TraceSlot forward_trace) configure "SMTP forwarder" 
 40   
 41   
 42 
 
 43   
 44   
 45  function forward_path mailto route -> computers 
 46    arg Str mailto route computers 
 47    if not (mailto parse any "<" any:(var Str to) ">" any) 
 48      mailto parse any:to 
 49    var Data:MailBox box :> mailbox to 
 50    if exists:box 
 51      return box:computer 
 52    box :> mailbox lower:to 
 53    if exists:box 
 54      return box:computer 
 55    if route<>"" 
 56      return route 
 57    computers := this_computer:env:"pliant":"mail":"forward_route" 
 58    if computers<>"" 
 59      return 
 60    var Str domain := to (to search "@" -1)+to:len 
 61    computers := dns_query domain 15 
 62    if computers="" 
 63      computers := dns_query domain 1 
 64   
 65   
 66 
 
 67   
 68   
 69  function backward_mail filename -> status 
 70    arg Str filename ; arg Status status 
 71    forward_trace trace "backwarding " filename 
 72    var (Link Database:MailMeta) db :> new Database:MailMeta 
 73    db load (replace filename ".mail" ".pdb") 
 74    var Data:MailMeta meta :> db data 
 75    if meta:from="" 
 76      file_delete filename 
 77      file_delete (replace filename ".mail" ".pdb") 
 78      file_directory_flush filename 
 79      file_hook filename 
 80      file_hook (replace filename ".mail" ".pdb") 
 81      return 
 82    (var Stream dest) open (replace filename ".mail" ".tmp") out+safe 
 83    dest writeline "Subject: Mail delivery failure" 
 84    dest writeline "To: "+meta:from 
 85    dest writeline "" 
 86    each target meta:target 
 87      if target:status<>"S" 
 88        dest writeline "Could not send the mail to "+target:box 
 89        dest writeline "Tryed "+(string target:try_count)+" times." 
 90        dest writeline "At the last try, on "+(string target:last_server) 
 91        dest writeline "SMTP server '"+target:last_server+"' reported the following"+(shunt target:status="R" " fatal" "")+" error:" 
 92        dest writeline target:last_error 
 93        dest writeline "" 
 94    dest writeline "The beginning of the mail was: " 
 95    (var Stream src) open filename in+safe 
 96    while not src:atend and src:line_number<60 
 97      dest writeline src:readline 
 98    src close ; dest close 
 99    var Str from := meta from 
 100    data_reset meta 
 101    meta:target create "" 
 102    meta:target:"":box := from 
 103    db store 
 104    file_delete filename ; file_move (replace filename ".mail" ".tmp"filename 
 105    file_directory_flush filename 
 106    file_hook filename 
 107   
 108     
 109  function command s cmd answer log -> c 
 110    arg_rw Stream s ; arg Str cmd ; arg_w Str answer ; arg_rw TraceSession log ; arg Int c 
 111    if cmd<>"" 
 112      writeline cmd 
 113      log trace "query " cmd 
 114    answer := readline   
 115    log trace "answer " answer 
 116    if s=failure 
 117      return 458 
 118    while (answer parse "-" any) 
 119      answer := readline 
 120      log trace "answer " answer 
 121    if not (answer parse _ any) 
 122      return (shunt answer="" 459 509) 
 123   
 124  function command s cmd log -> c 
 125    arg_rw Stream s ; arg Str cmd ; arg_w TraceSession log ; arg Int c 
 126    := command cmd (var Str answer) log 
 127   
 128  function command s cmd comment msg fatal log -> escape 
 129    arg_rw Stream s ; arg Str cmd comment ; arg_rw Str msg ; arg_rw CBool fatal ; arg_rw TraceSession log ; arg CBool escape 
 130    var Int err := command cmd  (var Str answer) log 
 131    escape := err>=400 
 132    if escape 
 133      msg := comment+": "+answer 
 134      if err>=500 
 135        fatal := true 
 136   
 137  function conforming_name n -> c 
 138    arg Str c 
 139    if not (parse any "<" any:(var Str m) ">" any) 
 140      parse any:m 
 141    := "<"+m+">" 
 142   
 143   
 144  function forward_to_server filename meta server target -> status 
 145    arg Str filename ; arg_rw Data:MailMeta meta ; arg Str server ; arg_rw Data:MailMetaTarget target ; arg Status status 
 146    (var TraceSession log) bind forward_trace 
 147    log trace "forwarding " filename " to " server 
 148    var CBool direct := meta direct 
 149    var Str route := meta route 
 150    var List:Str ontheway 
 151    if exists:target 
 152      ontheway += keyof target 
 153    else 
 154      each meta:target 
 155        if t:status=" " 
 156          part scan_computers 
 157            var Str computers := forward_path t:box route 
 158            while computers<>"" 
 159              if not (computers parse any:(var Str computer) _ any:(var Str remain)) 
 160                computer := computers ; remain := "" 
 161              if computer=server 
 162                ontheway += keyof t 
 163                leave scan_computers 
 164              if direct 
 165                leave scan_computers 
 166              computers := remain 
 167    var DateTime timestamp := datetime 
 168    var Pointer:Str id :> ontheway first 
 169    while exists:id 
 170      var Data:MailMetaTarget :> meta:target:id 
 171      try_count += 1 
 172      last_try := timestamp 
 173      last_server := server 
 174      last_error := "sending" 
 175      id :> ontheway next id 
 176    status := failure 
 177    var CBool some := false ; var Str msg := "Pliant internal bug" ; var CBool fatal := false 
 178    part talk 
 179      var Str ip := dns_query server 1 
 180      if ip="" 
 181        log trace "could not find IP address of " server 
 182        msg := "could not find IP address of "+server 
 183        leave talk 
 184      (var Stream tcp) open "tcp://"+ip+"/client/25" in+out+safe+cr+lf 
 185      if tcp=failure 
 186        log trace "failed to connect to " server " SMTP TCP port" 
 187        msg := "failed to connect to "+server+" SMTP TCP port" 
 188        leave talk 
 189      tcp configure "priority low" 
 190      tcp configure "timeout "+string:forward_timeout 
 191      if (command tcp "" "server did not welcome us" msg fatal log) 
 192        leave talk 
 193      var Str smtp_name := this_computer:env:"pliant":"mail":"smtp_name" 
 194      if smtp_name="" 
 195        smtp_name := computer_fullname  
 196      if (command tcp "HELO "+smtp_name "server rejected our greeting" msg fatal log) 
 197        leave talk 
 198      if meta:from<>"" 
 199        if (command tcp "MAIL FROM:"+(conforming_name meta:from) "server rejected our from specification" msg fatal log) 
 200          leave talk 
 201      var Pointer:Str id :> ontheway first 
 202      while exists:id 
 203        var Data:MailMetaTarget :> meta:target:id 
 204        var Int err := command tcp "RCPT TO:"+(conforming_name t:box) (var Str answer) log 
 205        if err<300 
 206          some := true 
 207        else 
 208          last_error := shunt (answer parse word:"sending" any) "- "+answer+" -" answer 
 209          if err>=500 
 210            status := "R" 
 211        id :> ontheway next id 
 212      if not some 
 213        msg := "no recipient for the message." 
 214        leave talk 
 215      if (command tcp "DATA" "server rejected the mail (at beginning)" msg fatal log) 
 216        leave talk 
 217      if exists:target 
 218        tcp writeline "To: "+target:box 
 219      if verbose 
 220        var Intn total := (file_query filename standard) size 
 221      (var Stream mail) open filename in+safe 
 222      while not mail:atend 
 223        var Str := mail readline 
 224        if (0 1)="." 
 225          := "."+l 
 226        tcp writeline l 
 227        if verbose and (mail:line_number .and. 255)=1 
 228          if ((mail query "seek"parse (var Intn offset)) 
 229            var Pointer:Str id :> ontheway first 
 230            while exists:id 
 231              var Data:MailMetaTarget :> meta:target:id 
 232              if (t:last_error parse word:"sending" any) 
 233                last_error := "sending "+string:(cast 100*offset\total Int)+"%" 
 234              id :> ontheway next id 
 235      if (command tcp "." "server rejected the mail (at end)" msg fatal log) 
 236        leave talk 
 237      command tcp "QUIT" log 
 238      status := success 
 239    tcp close 
 240    var Pointer:Str id :> ontheway first 
 241    while exists:id 
 242      var Data:MailMetaTarget :> meta:target:id 
 243      if (t:last_error parse word:"sending" any) 
 244        if status=success 
 245          status := "S" 
 246          last_error := "" 
 247        else 
 248          last_error := msg 
 249      if fatal 
 250        status := "R" 
 251      id :> ontheway next id 
 252   
 253   
 254  function forward_mail filename -> status 
 255    arg Str filename ; arg Status status 
 256    forward_sem request filename 
 257    part do_forward "forwarding mail "+filename 
 258      if (file_query filename standard)=defined 
 259        forward_trace trace "forwarding " filename 
 260        var (Link Database:MailMeta) db :> new Database:MailMeta 
 261        db load (replace filename ".mail" ".pdb") 
 262        var Data:MailMeta meta :> db data 
 263        var CBool split := meta split 
 264        var CBool direct := meta direct 
 265        var Str route := meta route 
 266        if split and meta:threads>1 
 267          parallel threads meta:threads 
 268            each meta:target 
 269              if t:status=" " and not daemon_emergency 
 270                task 
 271                  part forward_to_one 
 272                    var Str computers := forward_path t:box route 
 273                    if computers="" 
 274                      forward_trace trace "no mail server or wrong domain for " t:box 
 275                      try_count += 1 
 276                      last_try := datetime 
 277                      last_server := "" 
 278                      last_error := "no mail server or wrong domain" 
 279                    while computers<>"" 
 280                      if not (computers parse any:(var Str computer) _ any:(var Str remain)) 
 281                        computer := computers ; remain := "" 
 282                      if (forward_to_server filename meta computer t)=success 
 283                        leave forward_to_one 
 284                      if direct 
 285                        leave forward_to_one 
 286                      computers := remain 
 287        else 
 288          var (Dictionary Str Void) tryed 
 289          each meta:target 
 290            part forward_to_one 
 291              if t:status<>" " or daemon_emergency 
 292                leave forward_to_one 
 293              var Str computers := forward_path t:box route 
 294              if computers="" 
 295                forward_trace trace "no mail server or wrong domain for " t:box 
 296                try_count += 1 
 297                last_try := datetime 
 298                last_server := "" 
 299                last_error := "no mail server or wrong domain" 
 300              while computers<>"" 
 301                if not (computers parse any:(var Str computer) _ any:(var Str remain)) 
 302                  computer := computers ; remain := "" 
 303                if split 
 304                  if (forward_to_server filename meta computer t)=success 
 305                    leave forward_to_one 
 306                else 
 307                  if not exists:(tryed first computer) 
 308                    tryed insert computer void 
 309                    if (forward_to_server filename meta computer (var Data:MailMetaTarget empty_target))=success 
 310                      leave forward_to_one 
 311                if direct 
 312                  leave forward_to_one 
 313                computers := remain 
 314        status := success ; var Int success_count := 0 ; var Int total_count := 0 
 315        var CBool try_again := datetime:seconds-meta:queued_on:seconds<meta:try_period 
 316        each meta:target 
 317          if t:status<>"S" 
 318            status := failure 
 319            if t:status=" " and t:try_count<meta:try_times 
 320              try_again := true 
 321          else 
 322            success_count += 1 
 323          total_count += 1 
 324        db store 
 325        var CBool surrender := not try_again and not meta:report 
 326        var CBool removed := (file_query filename standard)=undefined 
 327        if status=success or surrender or removed 
 328          forward_trace trace "removing " filename+" (forwarded "+string:success_count+"/"+string:total_count+(shunt surrender " surrender" "")+(shunt removed " removed" "")+")" 
 329          file_delete filename 
 330          file_delete (replace filename ".mail" ".pdb") 
 331          file_directory_flush filename 
 332          file_hook filename 
 333          file_hook (replace filename ".mail" ".pdb") 
 334        eif not try_again 
 335          backward_mail filename 
 336    forward_sem release filename 
 337   
 338  function forward_mail filename detached action -> status 
 339    arg Str filename ; arg CBool detached ; arg Str action ; arg Status status 
 340    if (forward_immediat nowait_request 1) 
 341      if detached 
 342        status := success 
 343        safe 
 344          thread 
 345            part async_forward action 
 346              forward_mail filename 
 347            forward_immediat release 1 
 348        failure 
 349          forward_immediat release 1 
 350          status := failure 
 351      else 
 352        part sync_forward action 
 353          status := forward_mail filename 
 354        forward_immediat release 1 
 355    else 
 356      forward_trace trace "fowarding delayed because all forwarding slots are currently in use" 
 357     
 358   
 359  function forward_path filename route options 
 360    arg Str filename ; arg Str route options 
 361    forward_sem request filename 
 362    if (file_query filename standard)=defined 
 363      var (Link Database:MailMeta) db :> new Database:MailMeta 
 364      db load (replace filename ".mail" ".pdb") 
 365      db:data route := route 
 366      if (options option "direct") 
 367        db:data direct := true 
 368      if (options option "indirect") 
 369        db:data direct := false 
 370      if (options option "split") 
 371        db:data direct := true 
 372      if (options option "group") 
 373        db:data direct := false 
 374      db store 
 375    forward_sem release filename 
 376   
 377   
 378 
 
 379   
 380   
 381  function forward_mails 
 382    if (this_computer:env:"pliant":"mail":"forward_immediat" parse (var Int n)) 
 383      forward_immediat configure n 
 384    daemon "mails forwarder daemon" 
 385      var CBool again := true 
 386      while again and not daemon_emergency 
 387        again := false 
 388        if not (this_computer:env:"pliant":"mail":"forward_sleep" parse (var Float f)) 
 389          := 3600 
 390        daemon_sleep f 
 391        if not daemon_emergency 
 392          var (Dictionary Str CBool) done_path := var (Dictionary Str CBool) empty_dictionary 
 393          if not (this_computer:env:"pliant":"mail":"forward_threads" parse (var Int n)) 
 394            := 1 
 395          parallel threads n 
 396            each box mailbox 
 397              var Str path 
 398              if box:computer=computer_fullname 
 399                path := box out_path 
 400              eif box:relay_computer=computer_fullname 
 401                path := box relay_path 
 402              else 
 403                path := "" 
 404              if path<>"" and not exists:(done_path first path) and pliant_execution_phase<=execution_phase_run 
 405                done_path insert path true 
 406                var Array:FileInfo files := file_list path standard 
 407                for (var Int i) files:size-1 
 408                  if files:i:extension=".mail" and not daemon_emergency 
 409                    again := true 
 410                    var Str name := files:name 
 411                    task 
 412                      forward_mail name 
 413   
 414  forward_mails 
 415   
 416   
 417  export forward_mail forward_mails forward_path