/pliant/protocol/smtp/server.pli
 
 1  abstract 
 2    [This is Pliant SMTP server implementation (RFC 821)] 
 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/install/minimal.pli" 
 20  module "/pliant/language/compiler.pli" 
 21  module "/pliant/language/context.pli" 
 22  module "/pliant/language/stream.pli" 
 23  module "/pliant/admin/file.pli" 
 24  module "/pliant/language/os/socket.pli" 
 25  module "/pliant/protocol/common/tcp_server.pli" 
 26  module "/pliant/protocol/common/misc.pli" 
 27  module "/pliant/protocol/dns/client.pli" 
 28  module "/pliant/fullpliant/this_computer.pli" 
 29  module "/pliant/util/encoding/html.pli" 
 30  module "/pliant/util/encoding/date.pli" 
 31  module "meta.pli" 
 32  module "mail.pli" 
 33  module "forward.pli" 
 34  module "client.pli" 
 35  module "/pliant/language/schedule/resourcesem.pli" 
 36   
 37  constant pattern_matching true 
 38  constant use_spam_filter true 
 39   
 40  public 
 41    gvar Float smtp_auto_answer_timeout := 120 
 42   
 43  if use_spam_filter 
 44    module "spam.pli" 
 45   
 46   
 47  (gvar TraceSlot smtp_trace) configure "SMTP server" 
 48   
 49  function real_email full -> real 
 50    arg Str full real 
 51    if (full parse any "<" any:real ">" any) 
 52      void 
 53    eif (full parse any:real "(" any ")") 
 54      void 
 55    else 
 56      full parse any:real 
 57   
 58  function ac_real_email full -> real 
 59    arg Str full real 
 60    real := lower real_email:full 
 61   
 62   
 63 
 
 64   
 65   
 66  public 
 67    type SmtpServer 
 68      tcp_server_fields "SMTP" 25 
 69  TcpServer maybe SmtpServer 
 70   
 71   
 72  type SmtpFile 
 73    field CBool forward <- false 
 74    field CBool push <- false 
 75    field List:Str to 
 76   
 77  type SmtpSession 
 78    field Str local_name 
 79    field Str remote_name 
 80    field Str remote_ip 
 81    field CBool remote_magic <- false 
 82    field Str id 
 83    field CBool welcome <- false 
 84    field CBool accepted <- false 
 85    field CBool rejected <- false 
 86    field CBool magic <- false 
 87    field Str from  ; field Str outmail 
 88    field List:Str to 
 89    field (Dictionary Str SmtpFile) files 
 90    field (Dictionary Str CBool) to_confirmed 
 91    field CBool check_ip check_from check_to <- false 
 92    field TraceSession log 
 93    if use_spam_filter 
 94      field List:Str spam_filters 
 95      field Int spam_level <- -1 
 96    field Str auto_from auto_to auto_subject auto_messageid auto_answer 
 97   
 98   
 99  method session reset 
 100    arg_rw SmtpSession session 
 101    session id := generate_id 
 102    session rejected := false 
 103    session accepted := false 
 104    session magic := session remote_magic 
 105    session from := "" ; session outmail := "" 
 106    session to := var List:Str empty_to 
 107    session files := var (Dictionary Str SmtpFile) empty_files 
 108    session check_ip := false 
 109    session check_from := false 
 110    session check_to := false 
 111    session auto_from := "" ; session auto_to := "" ; session auto_subject := "" ; session auto_messageid := "" ; session auto_answer := "" 
 112    if use_spam_filter 
 113      session spam_level := -1 
 114   
 115   
 116  method session add_file filename target -> file 
 117    arg_rw SmtpSession session ; arg Str filename target ; arg_RW SmtpFile file 
 118    file :> session:files first filename 
 119    if not exists:file 
 120      session:files insert filename (var SmtpFile empty_list) 
 121      file :> session:files filename 
 122    if target<>"" 
 123      if not exists:(session:to_confirmed first ac_real_email:target) 
 124        session:to_confirmed insert ac_real_email:target (exists mailbox:(real_email target):accept_from:(real_email session:from)) 
 125   
 126  method session check_from_to b 
 127    arg_rw SmtpSession session ; arg Data:MailBox b 
 128    if session:outmail<>"" 
 129      session check_from := true 
 130      session check_to := true 
 131    if b:check_ip 
 132      session check_ip := true 
 133    if b:check_from 
 134      session check_from := true 
 135    if b:check_to 
 136      session check_to := true 
 137   
 138  method session receive_mail_content s filename -> a 
 139    arg_rw SmtpSession session ; arg_rw Stream s ; arg Str filename a 
 140    a := "" 
 141    (var Stream mail) open filename out+mkdir+safe 
 142    mail writeline "Received: from "+session:remote_name+"("+session:remote_ip+") by "+session:local_name+"; "+rfc1123_date:datetime 
 143    var CBool from_provided := false 
 144    var Int loop := 0 
 145    var Str suspicious := "" ; var List:Str comments 
 146    var CBool empty_line := false 
 147    if session:check_ip and session:outmail="" and (dns_query session:remote_name 1)<>session:remote_ip 
 148      suspicious += " server" ; comments += "Sending server is suspicious." 
 149    part receive_header 
 150      while not s:atend and { var Str l := s readline ; l<>"." } 
 151        if l="" 
 152          empty_line := true 
 153          leave receive_header 
 154        while not s:atend and { var Char ch := s:stream_read_cur map Char ; ch=" " or ch="[tab]" } 
 155          l += s readline 
 156        if (l parse acpattern:"From:" any:(var Str from)) 
 157          if ac_real_email:from<>(ac_real_email session:from) and session:check_from 
 158            suspicious += " from" ; comments += "Sender configuration is suspicious." # The '"+l+"' in the mail header does not match the 'MAIL FORM: "+session:from+"' provided as an SMTP instruction. 
 159          from_provided := true 
 160          var Str from2 := ac_real_email from 
 161          if exists:(mail_database:data:magic_from from2) 
 162            session magic := true 
 163          eif exists:(mail_database:data:black_from from2) 
 164            session spam_level := 1 ; comments += "Sender mailbox is blacklisted." 
 165          from2 := from2 (from2 search "@" from2:len)+1 from2:len 
 166          if exists:(mail_database:data:magic_from from2) 
 167            session magic := true 
 168          eif exists:(mail_database:data:black_from from2) 
 169            session spam_level := 1 ; comments += "Sender domain is blacklisted." 
 170          if session:check_ip and (dns_query from2 15)="" and (dns_query from2 1)="" 
 171            suspicious += " domain" ; comments += "Sender domain is suspicious." 
 172          session auto_from := from 
 173        eif (l parse acpattern:"To:" any:(var Str tos)) or (l parse acpattern:"Cc:" any:(var Str tos)) 
 174          while tos<>"" 
 175            if not (tos parse any:(var Str to) "," any:(var Str remain)) 
 176              to := tos ; remain := "" 
 177            if exists:(session:to_confirmed first ac_real_email:to) 
 178              session:to_confirmed ac_real_email:to := true 
 179            tos := remain 
 180        eif (l parse acpattern:"Received:" any "(" any ")" word:"by" any:(var Str srv) ";" any) 
 181          if srv=session:local_name 
 182            loop += 1 
 183            if loop>1 
 184              a := "559 The mail is looping between SMTP servers." 
 185        eif (l parse acpattern:"Subject:" any:(var Str subject)) 
 186          session auto_subject := subject 
 187        eif (l parse acpattern:"Message-ID:" any:(var Str messageid)) 
 188          session auto_messageid := messageid 
 189        if (l 0 2)=".." 
 190          l := l 1 l:len 
 191        mail writeline l 
 192        session:log trace "header " l 
 193        plugin mail_header_line 
 194    if session:check_to 
 195      var Pointer:CBool c :> session:to_confirmed first 
 196      while exists:c 
 197        if not c 
 198          suspicious += " to" ; comments += "Recipients list is suspicious." # 'To:' or 'Cc:' is missing or wrong in the mail header. 
 199        c :> session:to_confirmed next c 
 200    if session:check_from 
 201      if session:from<>"" and not from_provided 
 202        suspicious += " from" ; comments += "This mail might come from "+session:from 
 203    if suspicious<>"" 
 204      mail writeline "Suspicious:"+suspicious 
 205    if empty_line 
 206      mail writeline l 
 207    if (exists comments:first) and not session:magic 
 208      if session:outmail<>"" 
 209        if a="" 
 210          a := "553 "+comments:first 
 211      else 
 212        mail writeline "Mail agent comments:" 
 213        var Pointer:Str comment :> comments first 
 214        while exists:comment 
 215          mail writeline "  "+comment 
 216          comment :> comments next comment 
 217        mail writeline "" 
 218    var CBool empty := true 
 219    if l<>"." 
 220      while not s:atend and { var Str l := s readline ; l<>"." } 
 221        if (l 0 2)=".." 
 222          l := l 1 l:len 
 223        mail writeline l 
 224        if l<>"" 
 225          empty := false 
 226    if session:auto_subject="" and empty 
 227      session spam_level := 1 
 228    if s=failure 
 229      a := "458 Broken TCP connection" 
 230    if mail:close=failure and a="" 
 231      a := "452 Requested action not taken: insufficient system storage" 
 232    if use_spam_filter and not session:magic 
 233      var Pointer:Str sf :> session:spam_filters first 
 234      while exists:sf and session:spam_level<1 
 235        session spam_level := max session:spam_level (spam_filter filename sf) 
 236        sf :> session:spam_filters next sf 
 237   
 238   
 239  method session receive_mail s -> a 
 240    arg_rw SmtpSession session ; arg_rw Stream s ; arg Str a 
 241    var CBool stored := false 
 242    var CBool failed := false 
 243    var Str forwards 
 244    var Str temp 
 245    a := "550 Rejected without any explaination" 
 246    part store 
 247      var Pointer:SmtpFile c :> session:files first 
 248      while exists:c 
 249        if not stored 
 250          a := "354 Start mail input; end with <CRLF>.<CRLF>" 
 251          s writeline a 
 252          session:log trace "answer " a 
 253          temp := (session:files key c)+".tmp" 
 254          a := session receive_mail_content s temp 
 255          if a<>"" 
 256            leave store 
 257          stored := true 
 258        else 
 259          if (file_clone temp (session:files key c)+".tmp")=failure and (file_copy temp (session:files key c)+".tmp")=failure 
 260            failed := true 
 261            a := "451 Requested action aborted: local error in processing" 
 262            leave store 
 263        if (exists c:to:first) 
 264          var (Link Database:MailMeta) db :> new Database:MailMeta 
 265          db load (session:files key c)+".pdb" 
 266          var Data:MailMeta meta :> db data 
 267          meta queued_on := datetime 
 268          meta from := session from 
 269          var Pointer:Str t :> c:to first ; var Int i := 1 
 270          while exists:t 
 271            meta:target create string:i 
 272            meta:target:(string:i):box := t 
 273            t :> c:to next t ; i += 1 
 274          if c:push 
 275            meta push 
 276          if db:store=failure 
 277            session:log trace "failed to store meta datas for " session:id " in " (session:files key c)+".pdb" 
 278          forwards += string (session:files key c)+".mail" 
 279        c :> session:files next c 
 280    if stored and not failed 
 281      session:log trace "session ID is " session:id 
 282      var Pointer:SmtpFile c :> session:files first 
 283      while exists:c 
 284        if (exists c:to:first) or not c:forward 
 285          var Str mail := (session:files key c)+".mail" 
 286          if use_spam_filter and session:spam_level>=0 and (reverse:mail eparse any:(var Str tail) (pattern reverse:"/in/") any:(var Str head)) and (tail search "/" -1)=(-1) 
 287            set_spam_mark (session:files key c)+".tmp" true 
 288            mail := reverse:head+(shunt session:spam_level>0 "/spam/" "/unknown/")+reverse:tail 
 289            file_tree_create mail 
 290          file_move (session:files key c)+".tmp" mail 
 291          file_directory_flush mail 
 292          plugin just_received 
 293          # within your plugin, you can scan all receipients of the mail 
 294          # through something like: 
 295          #   var Pointer:Str to :> c:to first 
 296          #   while exists:to 
 297          #     ... 
 298          #     to :> c:to next to 
 299          file_hook mail 
 300        else 
 301          file_delete (session:files key c)+".tmp" 
 302        c :> session:files next c 
 303      a := "250 OK" 
 304      if forwards<>"" 
 305        forward_mails 
 306        if (forward_immediat nowait_request 1) 
 307          safe 
 308            thread 
 309              while (forwards parse (var Str forward) any:(var Str remain)) 
 310                forward_mail forward 
 311                forwards := remain 
 312              forward_immediat release 1 
 313          failure 
 314            forward_immediat release 1 
 315    else 
 316      var Pointer:SmtpFile c :> session:files first 
 317      while exists:c 
 318        file_delete (session:files key c)+".tmp" 
 319        file_delete (session:files key c)+".pdb" 
 320        c :> session:files next c 
 321   
 322   
 323  method smtp service s 
 324    arg_rw SmtpServer smtp ; arg_rw Stream s 
 325    var SmtpSession session 
 326    session:log bind smtp_trace 
 327    session remote_ip := s query "remote_ip_address" 
 328    var DateTime timestamp := datetime 
 329    timestamp split (var Int year) (var Int month) (var Int day) (var Int hour) (var Int minute) (var Int second) (var Float fraction) 
 330    session:log trace "SMTP connection start at " timestamp " from " session:remote_ip 
 331    part dialog "SMTP connection from "+session:remote_ip+" (started at "+string:timestamp+")" 
 332      each ip mail_database:data:magic_ip 
 333        if (session:remote_ip is_inside_ip_domain keyof:ip) 
 334          session remote_magic := true 
 335      if not session:remote_magic 
 336        each ip mail_database:data:black_ip 
 337          if (session:remote_ip is_inside_ip_domain keyof:ip) 
 338            s writeline "559 you are blacklisted on this site." 
 339            session:log trace "remote IP is blacklisted on this site." 
 340            leave dialog 
 341        if (session:remote_ip parse (var Int ip1) "." (var Int ip2) "." (var Int ip3) "." (var Int ip4)) 
 342          each dns mail_database:data:black_dns 
 343            if (dns_query string:ip4+"."+string:ip3+"."+string:ip2+"."+string:ip1+"."+keyof:dns)<>"" 
 344              s writeline "559 you are blacklisted on "+keyof:dns+" ("+(dns_query string:ip4+"."+string:ip3+"."+string:ip2+"."+string:ip1+"."+keyof:dns 16)+")" 
 345              session:log trace "remote IP is blacklisted on "+keyof:dns 
 346              leave dialog 
 347      session local_name := this_computer:env:"pliant":"mail":"smtp_name" 
 348      if session:local_name="" 
 349        session local_name := computer_fullname 
 350      s writeline "220 "+session:local_name+" Simple Mail Transfer Service Ready" 
 351      session:log trace "welcome 220 "+session:local_name+" Simple Mail Transfer Service Ready" 
 352      while not s:atend 
 353        var Str l := s readline 
 354        session:log trace "query " l 
 355        if (l parse any:(var Str first) _ any:(var Str second2) ":" any:(var Str remain)) 
 356          l := upper:first+" "+upper:second2+":"+remain 
 357        eif (l parse any:(var Str first) _ any:(var Str remain)) 
 358          l := upper:first+" "+remain 
 359        else 
 360          l := upper l 
 361        var Str a 
 362        if (l parse word:"HELO" (any session:remote_name)) 
 363          if exists:(mail_database:data:magic_name session:remote_name) 
 364            session remote_magic := true 
 365            session welcome := true 
 366          eif exists:(mail_database:data:black_name session:remote_name) 
 367            session welcome := false 
 368          else 
 369            session welcome := true 
 370          a := shunt session:welcome "250 "+session:local_name "550 No mail will be accepted here" 
 371          session reset 
 372          plugin command_helo 
 373        eif (l parse word:"MAIL" word:"FROM" ":" any:(var Str from)) 
 374          var Str from2 := ac_real_email from 
 375          if exists:(mail_database:data:magic_from from2) 
 376            session magic := true 
 377          eif exists:(mail_database:data:black_from from2) 
 378            session rejected := true 
 379          from2 := from2 (from2 search "@" from2:len)+1 from2:len 
 380          if exists:(mail_database:data:magic_from from2) 
 381            session magic := true 
 382          eif exists:(mail_database:data:black_from from2) 
 383            session rejected := true 
 384          var Data:MailBox b :> mailbox real_email:from 
 385          if not exists:b 
 386            b :> mailbox ac_real_email:from 
 387          if not session:welcome or session:rejected 
 388            a := "550 No mail will be accepted here" 
 389          eif session:from<>"" 
 390            session rejected := true 
 391            a := "503 Bad sequence of commands" 
 392          eif computer_fullname=b:computer and b:smtp_ip<>"" and (session:remote_ip is_inside_ip_domain b:smtp_ip) 
 393            # out mail from the mailbox owner 
 394            session from := from 
 395            session outmail := b out_path 
 396            var Pointer:SmtpFile file :> session add_file b:out_path+session:id "" 
 397            file forward := true 
 398            if b:archive and session:remote_name<>computer_fullname 
 399              session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id "" 
 400            session check_from_to b 
 401            a := "250 OK" 
 402          eif computer_fullname=b:relay_computer and session:remote_ip=(dns_query_prototype b:computer dns_query_function) 
 403            # out mail in the relay computer from the mailbox server computer 
 404            session from := from 
 405            session outmail := b relay_path 
 406            var Pointer:SmtpFile file :> session add_file b:relay_path+session:id "" 
 407            file forward := true 
 408            if b:relay_archive and session:remote_name<>computer_fullname 
 409              session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id "" 
 410            session check_from_to b 
 411            a := "250 OK" 
 412          else 
 413            session from := from 
 414            a := "250 OK" 
 415          plugin command_from 
 416        eif (l parse word:"RCPT" word:"TO" ":" any:(var Str to)) 
 417          var Str real_to := real_email to 
 418          var Data:MailBox b :> mailbox real_to 
 419          if not exists:b 
 420            real_to := ac_real_email to 
 421            b :> mailbox real_to 
 422          if not session:welcome or session:rejected 
 423            a := "550 No mail will be accepted here" 
 424          eif computer_fullname=b:computer 
 425            if b:list 
 426              # mailing list 
 427              session accepted := true 
 428              if b:subscriber:size>0 
 429                var Pointer:SmtpFile file :> session add_file b:out_path+session:id to 
 430                each ms b:subscriber 
 431                  file to += ms 
 432                file forward := true 
 433                file push := true 
 434              if b:archive 
 435                session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id "" 
 436              session check_from_to b 
 437              a := "250 OK" 
 438            else 
 439              # in mail 
 440              session accepted := true 
 441              session add_file b:in_path+session:id to 
 442              if b:archive 
 443                session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id "" 
 444              session check_from_to b 
 445              if use_spam_filter and (file_query (b smart_path "")+"spam_filter.txt" standard)=defined 
 446                session spam_filters += (b smart_path "")+"spam_filter.txt" 
 447              a := "250 OK" 
 448              if b:auto_answer<>"" 
 449                session auto_to += " "+b:name+" <"+keyof:b+">" ; session auto_answer += b:auto_answer+"[lf]" 
 450          eif computer_fullname=b:relay_computer 
 451            # in mail in the relay computer 
 452            session accepted := true 
 453            var Pointer:SmtpFile file :> session add_file b:relay_path+session:id to 
 454            file to += to 
 455            file forward := true 
 456            if b:relay_archive 
 457              session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id "" 
 458            session check_from_to b 
 459            a := "250 OK" 
 460            if b:auto_answer<>"" 
 461              session auto_to += " "+b:name+" <"+keyof:b+">" ; session auto_answer += b:auto_answer+"[lf]" 
 462          eif session:outmail<>"" 
 463            if session:remote_name<>computer_fullname 
 464              session accepted := true 
 465              var Pointer:SmtpFile file :> session add_file session:outmail+session:id to 
 466              file to += to 
 467              a := "250 OK" 
 468            else 
 469              a := "550 the target mailbox is probably wrong (I'm trying to forward to myself !)" 
 470          else 
 471            a := "550 Mails to "+to+" are not accepted here" 
 472          plugin command_to 
 473          if a="250 OK" 
 474            session to += real_to 
 475        eif l="DATA" 
 476          if not session:welcome or session:rejected 
 477            a := "550 No mail will be accepted here" 
 478          eif not session:accepted 
 479            a := "503 Bad sequence of commands" 
 480          else 
 481            a := "" 
 482            plugin command_data 
 483          if a="" 
 484            a := session receive_mail s 
 485            if a="250 OK" and session:auto_answer<>"" and session:auto_from<>"" and (not use_spam_filter or session:spam_level<0) 
 486              (var Stream answer) open "smtp:"+session:auto_from "subject "+(string session:auto_subject)+(shunt session:auto_messageid<>"" " references "+(string session:auto_messageid) "")+" timeout "+string:smtp_auto_answer_timeout out+safe 
 487              answer writeline "Here is an automatic answer related to"+session:auto_to+":" 
 488              answer writeline "" 
 489              answer writechars session:auto_answer 
 490              answer close   
 491            session reset 
 492        eif pattern_matching and (l parse word:"VRFY" any:(var Str pattern)) 
 493          var Data:MailBox b :> mailbox real_email:pattern 
 494          if exists:b 
 495            a := "250 "+b:name+" <"+keyof:b+">" 
 496          else 
 497            var Int count := 0 
 498            each b mailbox 
 499              if ((lower b:name+" <"+keyof:b+">") search lower:pattern -1)<>(-1) 
 500                count += 1 
 501                a := "250 "+b:name+" <"+keyof:b+">" 
 502            if count=0 
 503              a := "550 String does not match anything" 
 504            eif count>1 
 505              a := "553 User ambiguous" 
 506          plugin command_vrfy 
 507        eif l="RSET" 
 508          session reset 
 509          a := "250 OK" 
 510        eif l="NOOP" 
 511          a := "250 OK" 
 512        eif l="QUIT" 
 513          a := "221 "+session:local_name+" Service closing transmission channel" 
 514        else 
 515          a := "502 Command not implemented" 
 516          plugin not_implemented 
 517        s writeline a 
 518        session:log trace "answer " a 
 519        if l="QUIT" 
 520          leave dialog 
 521    session:log trace "SMTP connection stop at " datetime " from " session:remote_ip 
 522     
 523   
 524  define_tcp_server SmtpServer smtp_server 
 525  export smtp_server 
 526   
 527