Patch title: Release 85 bulk changes
Abstract:
File: /pliant/protocol/smtp/server.pli
Key:
    Removed line
    Added line
abstract
  [This is Pliant SMTP server implementation (RFC 821)]

# 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/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/admin/file.pli"
module "/pliant/language/os/socket.pli"
module "/pliant/protocol/common/tcp_server.pli"
module "/pliant/protocol/common/misc.pli"
module "/pliant/protocol/dns/client.pli"
module "/pliant/fullpliant/this_computer.pli"
module "/pliant/util/encoding/html.pli"
module "/pliant/util/encoding/date.pli"
module "meta.pli"
module "mail.pli"
module "forward.pli"
module "spam.pli"
module "client.pli"
module "/pliant/language/schedule/resourcesem.pli"

constant pattern_matching true
constant use_spam_ip_filter false
constant use_spam_word_filter true
constant use_spam_filter true

public
  gvar Float smtp_auto_answer_timeout := 120

if use_spam_filter
  module "spam.pli"


(gvar TraceSlot smtp_trace) configure "SMTP server"

function real_email full -> real
  arg Str full real
  if (full parse any "<" any:real ">" any)
    void
  eif (full parse any:real "(" any ")")
    void
  else
    full parse any:real

function ac_real_email full -> real
  arg Str full real
  real := lower real_email:full


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


public
  type SmtpServer
    tcp_server_fields "SMTP" 25
TcpServer maybe SmtpServer


type SmtpFile
  field CBool forward <- false
  field CBool push <- false
  field List:Str to

type SmtpSession
  field Str local_name
  field Str remote_name
  field Str remote_ip
  field CBool remote_magic <- false
  field Str id
  field CBool welcome <- false
  field CBool accepted <- false
  field CBool rejected <- false
  field CBool magic <- false
  field CBool spam <- false
  field Str from  ; field Str outmail
  field (Dictionary Str SmtpFile) files
  field (Dictionary Str CBool) to_confirmed
  field CBool check_from check_to <- false
  field TraceSession log
  field List:Str spam_ip_filters
  field List:Str spam_word_filters
  if use_spam_filter
    field List:Str spam_filters
    field Int spam_level <- -1
  field Str auto_from auto_to auto_subject auto_messageid auto_answer


method session reset
  arg_rw SmtpSession session
  session id := generate_id
  session rejected := false
  session accepted := false
  session magic := session remote_magic
  session spam := false
  session from := "" ; session outmail := ""
  session files := var (Dictionary Str SmtpFile) empty_files
  session check_from := false
  session check_to := false
  session auto_from := "" ; session auto_to := "" ; session auto_subject := "" ; session auto_messageid := "" ; session auto_answer := ""
  if use_spam_filter
    session spam_level := -1


method session add_file filename target -> file
  arg_rw SmtpSession session ; arg Str filename target ; arg_RW SmtpFile file
  file :> session:files first filename
  if not exists:file
    session:files insert filename (var SmtpFile empty_list)
    file :> session:files filename
  if target<>""
    if not exists:(session:to_confirmed first ac_real_email:target)
      session:to_confirmed insert ac_real_email:target (exists mailbox:(real_email target):accept_from:(real_email session:from))

method session check_from_to b
  arg_rw SmtpSession session ; arg Data:MailBox b
  if session:outmail<>""
    session check_from := true
    session check_to := true
  if b:check_from
    session check_from := true
  if b:check_to
    session check_to := true

method session receive_mail_content s filename -> a
  arg_rw SmtpSession session ; arg_rw Stream s ; arg Str filename a
  a := ""
  (var Stream mail) open filename out+mkdir+safe
  mail writeline "Received: from "+session:remote_name+"("+session:remote_ip+") by "+session:local_name+"; "+rfc1123_date:datetime
  var CBool from_provided := false
  var Int loop := 0
  var List:Str comments
  part receive_header
    while not s:atend and { var Str l := s readline ; l<>"." }
      if l=""
        mail writeline l
        leave receive_header
      while not s:atend and { var Char ch := s:stream_read_cur map Char ; ch=" " or ch="[tab]" }
        l += s readline
      if (l parse acpattern:"From:" any:(var Str from))
        if ac_real_email:from<>(ac_real_email session:from) and session:check_from
          comments += "The '"+l+"' in the mail header does not match the 'MAIL FORM: "+session:from+"' provided as an SMTP instruction."
        from_provided := true
        var Str from2 := ac_real_email from
        if exists:(mail_database:data:magic_from from2)
          session magic := true
        eif exists:(mail_database:data:black_from from2)
          comments += "sender is assumed to be a spammer"
        from2 := from2 (from2 search "@" from2:len)+1 from2:len
        if exists:(mail_database:data:magic_from from2)
          session magic := true
        eif exists:(mail_database:data:black_from from2)
          comments += "sender is assumed to be a spammer"
        session auto_from := from
      eif (l parse acpattern:"To:" any:(var Str tos)) or (l parse acpattern:"Cc:" any:(var Str tos))
        while tos<>""
          if not (tos parse any:(var Str to) "," any:(var Str remain))
            to := tos ; remain := ""
          if exists:(session:to_confirmed first ac_real_email:to)
            session:to_confirmed ac_real_email:to := true
          tos := remain
      eif (l parse acpattern:"Received:" any "(" any ")" word:"by" any:(var Str srv) ";" any)
        if srv=session:local_name
          loop += 1
          if loop>1
            a := "559 The mail is looping between SMTP servers."
      eif (l parse acpattern:"Subject:" any:(var Str subject))
        session auto_subject := subject
      eif (l parse acpattern:"Message-ID:" any:(var Str messageid))
        session auto_messageid := messageid
      if (l 0 2)=".."
        l := l 1 l:len
      mail writeline l
      session:log trace "header " l
      plugin mail_header_line
  if session:check_to
    var Pointer:CBool c :> session:to_confirmed first
    while exists:c
      if not c
        comments += "'To:' or 'Cc:' is missing or wrong in the mail header."
      c :> session:to_confirmed next c
  if session:check_from
    if session:from<>"" and not from_provided
      comments += "'From:' is missing in the mail header."
  if (exists comments:first) and not session:magic
    if session:outmail<>""
      if a=""
        a := "553 "+comments:first
    else
      mail writeline "Pliant mailer is warning you that this mail is not correct:"
      var Pointer:Str comment :> comments first
      while exists:comment
        mail writeline "  "+comment
        comment :> comments next comment
      mail writeline ""
  if use_spam_ip_filter
    var Pointer:Str sf :> session:spam_ip_filters first
    while exists:sf and not session:spam
      mail flush anytime
      if (spam_ip_filter filename sf)
        session spam := true
      sf :> session:spam_ip_filters next sf
  if l<>"."
    while not s:atend and { var Str l := s readline ; l<>"." }
      if (l 0 2)=".."
        l := l 1 l:len
      mail writeline l
  if s=failure
    a := "458 Broken TCP connection"
  if mail:close=failure and a=""
    a := "452 Requested action not taken: insufficient system storage"
  if use_spam_word_filter
    var Pointer:Str sf :> session:spam_word_filters first
    while exists:sf and not session:spam
      if (spam_word_filter filename sf)
        session spam := true
      sf :> session:spam_word_filters next sf
  if use_spam_filter
    var Pointer:Str sf :> session:spam_filters first
    while exists:sf and session:spam_level<1
      session spam_level := max session:spam_level (spam_filter filename sf)
      sf :> session:spam_filters next sf


method session receive_mail s -> a
  arg_rw SmtpSession session ; arg_rw Stream s ; arg Str a
  var CBool stored := false
  var CBool failed := false
  var Str forwards
  var Str temp
  a := "550 Rejected without any explaination"
  part store
    var Pointer:SmtpFile c :> session:files first
    while exists:c
      if not stored
        a := "354 Start mail input; end with <CRLF>.<CRLF>"
        s writeline a
        session:log trace "answer " a
        temp := (session:files key c)+".tmp"
        a := session receive_mail_content s temp
        if a<>""
          leave store
        stored := true
      else
        if (file_clone temp (session:files key c)+".tmp")=failure and (file_copy temp (session:files key c)+".tmp")=failure
          failed := true
          a := "451 Requested action aborted: local error in processing"
          leave store
      if (exists c:to:first)
        var (Link Database:MailMeta) db :> new Database:MailMeta
        db load (session:files key c)+".pdb"
        var Data:MailMeta meta :> db data
        meta queued_on := datetime
        meta from := session from
        var Pointer:Str t :> c:to first ; var Int i := 1
        while exists:t
          meta:target create string:i
          meta:target:(string:i):box := t
          t :> c:to next t ; i += 1
        if c:push
          meta push
        if db:store=failure
          session:log trace "failed to store meta datas for " session:id " in " (session:files key c)+".pdb"
        forwards += string (session:files key c)+".mail"
      c :> session:files next c
  if stored and not failed
    session:log trace "session ID is " session:id
    var Pointer:SmtpFile c :> session:files first
    while exists:c
      if (exists c:to:first) or not c:forward
        var Str mail := (session:files key c)+".mail"
        if session:spam and (reverse:mail eparse any:(var Str tail) (pattern reverse:"/in/") any:(var Str head)) and (tail search "/" -1)=(-1)
        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)
          set_spam_mark (session:files key c)+".tmp" true
          mail := reverse:head+"/spam/"+reverse:tail
          mail := reverse:head+(shunt session:spam_level>0 "/spam/" "/unknown/")+reverse:tail
          file_tree_create mail
        file_move (session:files key c)+".tmp" mail
        file_directory_flush mail
        plugin just_received
        # within your plugin, you can scan all receipients of the mail
        # through something like:
        #   var Pointer:Str to :> c:to first
        #   while exists:to
        #     ...
        #     to :> c:to next to
        file_hook mail
      else
        file_delete (session:files key c)+".tmp"
      c :> session:files next c
    a := "250 OK"
    if forwards<>""
      forward_mails
      if (forward_immediat nowait_request 1)
        safe
          thread
            while (forwards parse (var Str forward) any:(var Str remain))
              forward_mail forward
              forwards := remain
            forward_immediat release 1
        failure
          forward_immediat release 1
  else
    var Pointer:SmtpFile c :> session:files first
    while exists:c
      file_delete (session:files key c)+".tmp"
      file_delete (session:files key c)+".pdb"
      c :> session:files next c


method smtp service s
  arg_rw SmtpServer smtp ; arg_rw Stream s
  var SmtpSession session
  session:log bind smtp_trace
  session remote_ip := s query "remote_ip_address"
  var DateTime timestamp := datetime
  timestamp split (var Int year) (var Int month) (var Int day) (var Int hour) (var Int minute) (var Int second) (var Float fraction)
  session:log trace "SMTP connection start at " timestamp " from " session:remote_ip
  part dialog "SMTP connection from "+session:remote_ip+" (started at "+string:timestamp+")"
    each ip mail_database:data:magic_ip
      if (session:remote_ip is_inside_ip_domain keyof:ip)
        session remote_magic := true
    if not session:remote_magic
      each ip mail_database:data:black_ip
        if (session:remote_ip is_inside_ip_domain keyof:ip)
          s writeline "559 you are blacklisted on this site."
          session:log trace "remote IP is blacklisted on this site."
          leave dialog
      if (session:remote_ip parse (var Int ip1) "." (var Int ip2) "." (var Int ip3) "." (var Int ip4))
        each dns mail_database:data:black_dns
          if (dns_query string:ip4+"."+string:ip3+"."+string:ip2+"."+string:ip1+"."+keyof:dns)<>""
            s writeline "559 you are blacklisted on "+keyof:dns+" ("+(dns_query string:ip4+"."+string:ip3+"."+string:ip2+"."+string:ip1+"."+keyof:dns 16)+")"
            session:log trace "remote IP is blacklisted on "+keyof:dns
            leave dialog
    session local_name := this_computer:env:"pliant":"mail":"smtp_name"
    if session:local_name=""
      session local_name := computer_fullname
    s writeline "220 "+session:local_name+" Simple Mail Transfer Service Ready"
    session:log trace "welcome 220 "+session:local_name+" Simple Mail Transfer Service Ready"
    while not s:atend
      var Str l := s readline
      session:log trace "query " l
      if (l parse any:(var Str first) _ any:(var Str second2) ":" any:(var Str remain))
        l := upper:first+" "+upper:second2+":"+remain
      eif (l parse any:(var Str first) _ any:(var Str remain))
        l := upper:first+" "+remain
      else
        l := upper l
      var Str a
      if (l parse word:"HELO" (any session:remote_name))
        if exists:(mail_database:data:magic_name session:remote_name)
          session remote_magic := true
          session welcome := true
        eif exists:(mail_database:data:black_name session:remote_name)
          session welcome := false
        else
          session welcome := true
        a := shunt session:welcome "250 "+session:local_name "550 No mail will be accepted here"
        session reset
        plugin command_helo
      eif (l parse word:"MAIL" word:"FROM" ":" any:(var Str from))
        var Str from2 := ac_real_email from
        if exists:(mail_database:data:magic_from from2)
          session magic := true
        eif exists:(mail_database:data:black_from from2)
          session rejected := true
        from2 := from2 (from2 search "@" from2:len)+1 from2:len
        if exists:(mail_database:data:magic_from from2)
          session magic := true
        eif exists:(mail_database:data:black_from from2)
          session rejected := true
        var Data:MailBox b :> mailbox real_email:from
        if not exists:b
          b :> mailbox ac_real_email:from
        if not session:welcome or session:rejected
          a := "550 No mail will be accepted here"
        eif session:from<>""
          session rejected := true
          a := "503 Bad sequence of commands"
        eif computer_fullname=b:computer and b:smtp_ip<>"" and (session:remote_ip is_inside_ip_domain b:smtp_ip)
          # out mail from the mailbox owner
          session from := from
          session outmail := b out_path
          var Pointer:SmtpFile file :> session add_file b:out_path+session:id ""
          file forward := true
          if b:archive
            session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id ""
          session check_from_to b
          a := "250 OK"
        eif computer_fullname=b:relay_computer and session:remote_ip=(dns_query_prototype b:computer dns_query_function)
          # out mail in the relay computer from the mailbox server computer
          session from := from
          session outmail := b relay_path
          var Pointer:SmtpFile file :> session add_file b:relay_path+session:id ""
          file forward := true
          if b:relay_archive
            session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id ""
          session check_from_to b
          a := "250 OK"
        else
          session from := from
          a := "250 OK"
        plugin command_from
      eif (l parse word:"RCPT" word:"TO" ":" any:(var Str to))
        var Data:MailBox b :> mailbox real_email:to
        if not exists:b
          b :> mailbox ac_real_email:to
        if not session:welcome or session:rejected
          a := "550 No mail will be accepted here"
        eif computer_fullname=b:computer
          if b:list
            # mailing list
            session accepted := true
            if b:subscriber:size>0
              var Pointer:SmtpFile file :> session add_file b:out_path+session:id to
              each ms b:subscriber
                file to += ms
              file forward := true
              file push := true
            if b:archive
              session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id ""
            session check_from_to b
            a := "250 OK"
          else
            # in mail
            session accepted := true
            session add_file b:in_path+session:id to
            if b:archive
              session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id ""
            session check_from_to b
            if (file_query (b smart_path "")+"spam_ip.txt" standard)=defined
              session spam_ip_filters += (b smart_path "")+"spam_ip.txt"
            if (file_query (b smart_path "")+"spam_word.txt" standard)=defined
              session spam_word_filters += (b smart_path "")+"spam_word.txt"
            if use_spam_filter and (file_query (b smart_path "")+"spam_filter.txt" standard)=defined
              session spam_filters += (b smart_path "")+"spam_filter.txt"
            a := "250 OK"
            if b:auto_answer<>""
              session auto_to += " "+b:name+" <"+keyof:b+">" ; session auto_answer += b:auto_answer+"[lf]"
        eif computer_fullname=b:relay_computer
          # in mail in the relay computer
          session accepted := true
          var Pointer:SmtpFile file :> session add_file b:relay_path+session:id to
          file to += to
          file forward := true
          if b:relay_archive
            session add_file b:archive_path+string:year+(right string:month 2 "0")+"/"+(right string:day 2 "0")+"/"+session:id ""
          session check_from_to b
          a := "250 OK"
          if b:auto_answer<>""
            session auto_to += " "+b:name+" <"+keyof:b+">" ; session auto_answer += b:auto_answer+"[lf]"
        eif session:outmail<>""
          if session:remote_name<>computer_fullname
            session accepted := true
            var Pointer:SmtpFile file :> session add_file session:outmail+session:id to
            file to += to
            a := "250 OK"
          else
            a := "550 the target mailbox is probably wrong (I'm trying to forward to myself !)"
        else
          a := "550 Mails to "+to+" are not accepted here"
        plugin command_to
      eif l="DATA"
        if not session:welcome or session:rejected
          a := "550 No mail will be accepted here"
        eif not session:accepted
          a := "503 Bad sequence of commands"
        else
          a := session receive_mail s
          if a="250 OK" and session:auto_answer<>"" and session:auto_from<>"" and (not use_spam_filter or session:spam_level<0)
            console "auto answering to " session:from eol
            (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
            answer writeline "Here is an automatic answer related to"+session:auto_to+":"
            answer writeline ""
            answer writechars session:auto_answer
            answer close  
          session reset
      eif pattern_matching and (l parse word:"VRFY" any:(var Str pattern))
        var Data:MailBox b :> mailbox real_email:pattern
        if exists:b
          a := "250 "+b:name+" <"+keyof:b+">"
        else
          var Int count := 0
          each b mailbox
            if ((lower b:name+" <"+keyof:b+">") search lower:pattern -1)<>(-1)
              count += 1
              a := "250 "+b:name+" <"+keyof:b+">"
          if count=0
            a := "550 String does not match anything"
          eif count>1
            a := "553 User ambiguous"
        plugin command_vrfy
      eif l="RSET"
        session reset
        a := "250 OK"
      eif l="NOOP"
        a := "250 OK"
      eif l="QUIT"
        a := "221 "+session:local_name+" Service closing transmission channel"
      else
        a := "502 Command not implemented"
        plugin not_implemented
      s writeline a
      session:log trace "answer " a
      if l="QUIT"
        leave dialog
  session:log trace "SMTP connection stop at " datetime " from " session:remote_ip
  

define_tcp_server SmtpServer smtp_server
export smtp_server