Patch title: Release 94 bulk changes
Abstract:
File: /pliant/protocol/pop3/server.pli
Key:
    Removed line
    Added line
# 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.

abstract
  [This is Pliant POP3 server implementation (RFC 1939)]


module "/pliant/install/minimal.pli"
module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/admin/file.pli"
module "/pliant/admin/md5.pli"
submodule "/pliant/protocol/common/tcp_server.pli"
module "/pliant/protocol/common/misc.pli"
module "/pliant/protocol/smtp/mail.pli"
module "/pliant/fullpliant/user.pli"

(gvar TraceSlot pop3_trace) configure "POP3 server"


public
  type Pop3Server
    tcp_server_fields "POP3" 110
TcpServer maybe Pop3Server
  

function list_begin files total
  arg_w Array:FileInfo files ; arg_w Intn total
  files size := 0

function list_add path level files
  arg Str path ; arg Str level ; arg_rw Array:FileInfo files
  var Array:FileInfo all := file_list path standard
  var Int j := files size
  files size += all size
  for (var Int i) 0 all:size-1
    if all:i:extension=".mail"
      files j := all i
      files:j options := "level "+string:level
      j += 1
  files size := j

function list_end files total
  arg_w Array:FileInfo files ; arg_w Intn total
  total := 0
  for (var Int i) 0 files:size-1
    total += files:i:size


type MailDirectory
  field Str path
  field Str md5
  field Str level

method pop3 service s
  arg_rw Pop3Server pop3 ; arg_rw Stream s
  var List:MailDirectory dir
  var Array:FileInfo files ; var Intn total := 0
  (var TraceSession log) bind pop3_trace
  s writeline "+OK POP3 server ready <>"
  log trace "POP3 connection start at " datetime " from " (s query "remote_ip_address")
  part dialog
    while not s:atend
      var Str l := s readline
      log trace "query " l
      if (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:"USER" any:(var Str user))
        dir := var List:MailDirectory empty_list
        if (exists mailbox:user)
          var Data:MailBox box :> mailbox user
          if box:computer<>computer_fullname
            a := "-ERR wrong server"
          eif box:pop3_level<"1" or not ((s query "remote_ip_address") is_inside_ip_domain box:pop3_ip)
            a := "-ERR not allowed"
          else
            a := "+OK "+user+" is a valid mailbox"
            var MailDirectory d
            d path := box in_path
            d md5 := mail_secret_database:data:box:user pop3_password_md5
            d level := box pop3_level
            dir += d
        eif (exists user:user)
          var CBool some := false ; a := ""
          each umb user:user:mailbox
            box :> mailbox umb
            if box:computer<>computer_fullname
              if a=""
                a := "-ERR wrong server"
            eif box:pop3_level<"1" or not ((s query "remote_ip_address") is_inside_ip_domain box:pop3_ip)
              if a=""
                a := "-ERR not allowed"
            else
              if not some
                a := "+OK "+keyof:box+" is a valid mailbox"
                some := true
              var MailDirectory d
              d path := box in_path
              d md5 := mail_secret_database:data:box:umb pop3_password_md5
              d level := box pop3_level
              dir += d
          if not some and a=""
            a := "-ERR sorry, no mailbox for user "+user+" here"
        else
          a := "-ERR sorry, no "+user+" user here"
      eif (l parse word:"PASS" any:(var Str password))
        a := "-ERR invalid password"
        list_begin files total
        var Pointer:MailDirectory c :> dir first
        while exists:c
          if string_md5_hexa_signature:password=c:md5
            a := "+OK logged in"
            list_add c:path c:level files
          c :> dir next c
        list_end files total
      eif (l parse word:"STAT")
        a := "+OK "+(string files:size)+" "+string:total
      eif (l parse word:"LIST")
        a := "+OK "+(string files:size)+" message"+(shunt files:size>1 "s" "")+" ("+string:total+" octet"+(shunt total>1 "s" "")+")"
        s writeline a
        log trace "answer " a
        for (var Int i) 0 files:size-1
          a := (string i+1)+" "+(string files:i:size)
          s writeline a
          log trace "list " a
        a := "."
      eif (l parse word:"LIST" (var Int i))
        if i>0 and i<=files:size
          a := "+OK "+string:i+" "+(string files:(i-1):size)
        else
          a := "-ERR no such message, only "+(string files:size)+" message"+(shunt files:size>1 "s" "")+" in "+user+" mailbox"
      eif { var Int maxl := -1 ; (l parse word:"RETR" (var Int i)) or (l parse word:"TOP" i maxl) }
        if i<1 or i>files:size
          a := "-ERR no such message"
        eif (files:(i-1):options option "level" Str)<"2"
          a := "-ERR not allowed"
        else
          a := "+OK"
          if maxl<0
            a += " "+string:i+" "+(string files:(i-1):size)+" octet"+(shunt files:(i-1):size>1 "s" "")
          s writeline a
          log trace "answer " a
          var Int decrement := 0
          (var Stream data) open files:(i-1):name in+safe
          while not data:atend and not maxl=0
            var Str l := data readline
            if (l 0 1)="."
              l := "."+l
            s writeline l
            maxl -= decrement
            if l=""
              decrement := 1
          data close
          a := "."
      eif (l parse word:"DELE" (var Int i))
        if i<1 or i>files:size
          a := "-ERR no such message"
        eif files:(i-1):options="delete"
          a := "-ERR message "+string:i+" already deleted"
        eif (files:(i-1):options option "level" Str)<"3"
          a := "-ERR not allowed"
        else
          a := "+OK message "+string:i+" deleted"
          files:(i-1):options := "delete"
      eif l="NOOP"
        a := "+OK"
      eif l="RSET"
        for (var Int i) 0 files:size-1
          files:i options := ""
        a := "+OK reseted"
      eif l="QUIT"
        for (var Int i) 0 files:size-1
          if files:i:options="delete"
            file_delete files:i:name
            file_hook files:i:name
        a := "+OK"
      else
        a := "-ERR Command not implemented"
      s writeline a
      log trace "answer " a
      if l="QUIT"
        leave dialog
  log trace "POP3 connection stop at " datetime " from " (s query "remote_ip_address")


define_tcp_server Pop3Server pop3_server
export pop3_server