Patch title: Release 87 bulk changes
Abstract:
File: /pliant/protocol/ftp/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 FTP server implementation (RFC 959)]


module "/pliant/language/unsafe.pli"
module "/pliant/language/context.pli"
module "/pliant/language/compiler.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/http/site.pli"
module "/pliant/fullpliant/user.pli"
module "/pliant/fullpliant/login.pli"
module "/pliant/language/os/socket.pli"


constant passive true
constant active true

(gvar TraceSlot ftp_trace) configure "FTP server"


public
  type FtpServer
    tcp_server_fields "FTP" 21
    field CBool send_software_release_number <- true
    field CBool unix_style <- true
TcpServer maybe FtpServer

type FtpEnv
  field Pointer:FtpServer server
  field Link:Stream command
  field Stream data
  field Data:Site site
  field Str user <- "" ; field Int user_auth_level <- 0
  field Dictionary rights
  field Str port
  field Str cwd <- "/"
  field TraceSession log
 

method env writeline line
  arg_rw FtpEnv env ; arg Str line
  env:command writeline line
  env:log trace "answer " line

method env try_site site -> status
  arg_rw FtpEnv env ; arg Data:Site site ; arg Status status
  if not exists:site
    return failure
  if site:computer<>computer_fullname and site:computer<>""
    return failure
  if site:protocol<>"FTP"
    return failure
  var Str ip := env:command query "local_ip_address"
  if ip<>"" and site:ip<>ip and site:ip<>""
    return failure
  if ((env:command query "local_ip_port") parse (var Int port)) and site:port<>port and site:port=defined
    return failure
  if site:protocol<>"" and site:protocol<>"FTP"
    return failure
  env:log trace "site is " keyof:site
  env site :> site
  status := success

method env assign_user
  arg_rw FtpEnv env
  env rights := var Dictionary empty_dictionary
  var Str ruser := env:command safe_query "remote_user"
  if ruser<>""
    env user := ruser
    env user_auth_level := 3
    env site :> site (env:command safe_query "local_user")
  else
    part scan_for_site
      each s site
        if s:protocol="FTP" and (s:computer<>"" or s:ip<>"")
          if (env try_site s)=success
            leave scan_for_site
      each s site
        if s:ip<>""
          if (env try_site s)=success
            leave scan_for_site
      each s site
        if s:computer<>""
          if (env try_site s)=success
            leave scan_for_site
      each s site
        if (env try_site s)=success
          leave scan_for_site
      return
  var Str rights
  var Str ip := env:command query "remote_ip_address"
  for (var Int lap) (shunt env:user<>"" 1 0) 0 step -1
    var Data:User u :> user (shunt lap=0 "anonymous" env:user)
    each r u:right
      if (string env:user_auth_level)>=r:auth and (ip is_inside_ip_domain r:ip) and (r:server="" or (" "+r:server+" " search " "+computer_fullname+" " -1)<>(-1))
        env:rights kmap r:right CBool := true
        rights += " "+r:right
  env:log trace "user " env:user " " env:user_auth_level " :" rights
  if env:user<>""
    if not (login_record env:user ip "FTP "+(string env:user_auth_level))
      env user := ""
      env user_auth_level := 0
      env rights := var Dictionary empty_dictionary


method env connect
  arg_rw FtpEnv env
  if env:data:is_open
    var Link:Stream data :> env data
    if ((env:data query "connection_handle") parse (var Int handle)) and (os_socket_wait handle 1 120)=success
      env:data configure "connect"
    else
      env:data error "Timeout on pending FTP connection"
    if (env:data query "remote_ip_address")<>(env:command query "remote_ip_address")
      env:data error "Wrong client connected to pending FTP connection"
  else
    env:data open env:port in+out+safe+cr+lf


method env allowed path1 write filename -> allow
  arg FtpEnv env ; arg Str path1 ; arg CBool write ; arg_w Str filename ; arg CBool allow
  var Data:SiteArea area
  var Str path := shunt (path1 0 1)="/" path1 env:cwd+path1
  var Str ext := path
  ext := ext (ext search_last "/" -1)+1 ext:len
  ext := ext (ext search_last "." ext:len) ext:len
  var Int longuest := 0
  each a env:site:area
    var Str p := a path ; var Str e := a extension
    if (path 0 p:len)=p and (e=ext or e="")
      var Int l := p:len+(shunt e=ext 10^9 0)
    var Str p := a path
    if (path 0 p:len)=p
      var Int l := p len
      if l>longuest
        area :> a
        longuest := l
      eif l=longuest
        area :> var Data:SiteArea nonexisting_area
  if area:root=""
    filename := env:site:root+(path 1 path:len)
  else
    filename := area:root+(path area:path:len path:len)
  var Str cond := shunt write area:write area:read
  allow := cond<>"" and (env:rights first cond)<>null or (env:rights first "administrator")<>null


function ftp_read filename from ftp env
  arg Str filename ; arg Intn from ; arg_rw Stream ftp ; arg_rw FtpEnv env
  var Str real := filename
  plugin read_name
  var Stream file ; file open real in+safe+(shunt from=0 bigcache 0)
  if file=success
    if from<>0
      file configure "seek "+string:from
    env writeline "150 ready to read file "+file:name ; ftp flush async
    env connect
    while not file:atend and env:data<>failure
      var Address adr ; var Int size
      file read_available adr size
      env:data raw_write adr size
    if file:close=success and env:data:close=success
      env writeline "226 File "+file:name+" has been red successfully."
    else
      env writeline "551 Failed to read from disk."
  else
    env writeline "550 Failed to open file "+file:name
  

function ftp_write filename from ftp env
  arg Str filename ; arg Intn from ; arg_rw Stream ftp ; arg_rw FtpEnv env
  var Str real := filename
  plugin write_name
  var Stream file ; file open real out+safe+(shunt from=0 bigcache 0)
  if file=success
    if from<>0
      file configure "seek "+string:from
    env writeline "150 ready to write file "+file:name ; ftp flush async
    env connect
    while not env:data:atend
      var Address adr ; var Int size
      env:data read_available adr size
      file raw_write adr size
    if file:close=success and env:data:close=success
      env writeline "226 File "+file:name+" has been written successfully."
    else
      env writeline "551 Failed to write to disk."
  else
    env writeline "550 Failed to open file "+file:name
  

function ftp_list filename original_name details_level ftp env
  arg Str filename original_name ; arg Int details_level ; arg_rw Stream ftp ; arg_rw FtpEnv env
  env writeline "150 "+(repeat 60 "-") ; ftp flush async
  var Str real := filename
  var Str f := shunt (original_name 0 1)="/" original_name env:cwd+original_name
  if f:len>=4 and (f f:len-4 4)="/*.*"
    real := real 0 real:len-3 ; f := f 0 f:len-3
  eif f:len>=2 and (f f:len-2 2)="/*"
    real := real 0 real:len-1 ; f := f 0 f:len-1
  if f:len=0 or (f f:len-1)<>"/"
    real += "/" ; f += "/"
  plugin list_name
  var Array:FileInfo files := file_list real (shunt details_level>2 extended standard)+relative+directories
  var Dictionary known ; var CBool computed := false
  each a env:site:area
    if (a:path 0 f:len)=f and a:root<>""
      var Str sub := a:path f:len a:path:len
      if (sub search_last "/" -2)=sub:len-1
        if not computed
          for (var Int i) 0 files:size-1
            known insert files:i:name true addressof:void
          computed := true
        if (known first sub)=null
          var FileInfo extra := file_query (shunt a:root<>"" a:root env:site:root+(a:path 1 a:path:len)) (shunt details_level>2 extended standard)+directories
          extra name := sub
          files += extra
  if files:size=0 and filename:len<>0 and (filename real:len-1)<>"/"
    var FileInfo file := file_query filename extended+relative
    if file=defined
      file name := file name_without_path
      files += file
  plugin list_content
  env connect
  for (var Int i) 0 files:size-1
    if details_level>0
      var Str l
      if (env:server:unix_style and details_level<2)
        l := (shunt files:i:is_directory "d" "-")+"rwxrwxrwx"
        # var Int mode := files:i:options option "mode" Int
        # if mode=undefined
        #   mode := 0
        # for (var Int j) 8 0 step -1
        #   l += shunt (mode .and. 2^j)<>0 "xwr":(j%3) "-"
        l += "   0 any      any  "+(right (string files:i:size) 12 " ")
        var Int year month day hour minute second ; var Float fraction
        var DateTime dt := files:i:datetime
        if dt=undefined
          dt := datetime
        dt split year month day hour minute second fraction
        # var Str d := day_name files:i:datetime:day_of_week
        # l += " "+upper:(d 0 1)+(d 1 2)
        l += " "+("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec" (month-1)*4 3)
        l += " "+(right string:day 2 " ")
        if false
          l += " "+(right string:hour 2 "0")
          l += ":"+(right string:minute 2 "0")
          # l += ":"+(right string:second 2 "0")
        else
          l += " "+(right string:year 5 " ")
        l += " "+(shunt files:i:is_directory (files:i:name 0 files:i:name:len-1) files:i:name)
        plugin list_unix_file
      else
        var Str opt := string files:i:options
        opt := (shunt opt:len>2 " " "")+(opt 1 opt:len-2)
        l := (left (string files:i:name) 42 " ")+" "+(right (string files:i:size) 12 " ")+" "+(string files:i:datetime)+opt
        plugin list_pliant_file
      env:data writeline l
      env:log trace "list " l
    else
      env:data writeline files:i:name
      env:log trace "list " files:i:name
  env:data close
  env writeline "226 "+(repeat 60 "-")


method server service ftp
  arg_rw FtpServer server ; arg_rw Stream ftp
  var FtpEnv env
  env:log bind ftp_trace
  env server :> server
  env command :> ftp
  env assign_user
  env:log trace "FTP connection start at " datetime " from " (ftp query "remote_ip_address")
  ftp writeline "220 Welcome to Pliant FTP server"
  env:log trace "welcome 220 Welcome to Pliant FTP server"
  var Str user_name
  part dialog
    while not ftp:atend
      var Str cmd := ftp readline
      env:log trace "query " cmd
      if (plugin condition false)
        plugin action
      eif (cmd parse word:"USER" any:user_name)
        plugin command_user
          env writeline "331 User name okay, need password."
      eif (cmd parse word:"PASS" any:(var Str password))
        plugin command_pass
          var Data:UserSecret u :> user_secret_database:data:user user_name
          if (plugin login string_md5_hexa_signature:password=u:password_md5)
            env user := user_name ; env:user_auth_level := 1 ; env assign_user
            env writeline "230 User logged in."
          eif user_name="" or user_name="anonymous"
            env writeline "230 User logged in."
          else
            sleep 1
            env writeline "531 Bad password for "+user_name
        plugin login
      eif (cmd parse word:"PORT" (var Int i1) "," (var Int i2) "," (var Int i3) "," (var Int i4) "," (var Int p1) "," (var Int p2))
        plugin command_port
          if passive and env:data:is_open
            env writeline "200 ok"
          eif active
            (ftp query "remote_ip_address") parse (var Int j1) "." (var Int j2) "." (var Int j3) "." (var Int j4)
            if j1=i1 and j2=i2 and j3=i3 and j4=i4
              env port := "tcp://"+string:i1+"."+string:i2+"."+string:i3+"."+string:i4+"/client/"+(string p1*256+p2)
              env writeline "200 ok"
            else
              env port := ""
              env writeline "500 Illegal PORT command."
          else
            env port := ""
            env writeline "500 Illegal PORT command."
      eif passive and (cmd parse word:"PASV")
        plugin command_passive
          env:data open "tcp:/server/any" "noautoconnect" in+out+safe+cr+lf
          (env:data query "local_ip_port") parse (var Int port)
          env writeline "227 Entering Passive Mode. ("+(replace (ftp query "local_ip_address") "." ",")+","+(string port\256)+","+(string port%256)+")"
      eif (cmd parse word:"RETR" any:(var Str path))
        plugin command_retr
          if (env allowed path false (var Str filename))
            ftp_read filename 0 ftp env
          else
            env writeline "530 Your are not allowed to access that file."
      eif (cmd parse word:"STOR" any:path)
        plugin command_stor
          if (env allowed path true filename)
            ftp_write filename 0 ftp env
          else
            env writeline "530 Your are not allowed to access that file."
      eif (cmd parse word:"CWD" any:path) or (cmd parse word:"CDUP")
        plugin command_cwd
          var Str dir
          if (cmd parse word:"CDUP") 
            dir := shunt env:cwd="/" "/" env:cwd+"../"
          else
            dir := shunt (path 0 1)="/" path env:cwd+path
            if dir="" or (dir dir:len-1)<>"/"
              dir += "/"
          while ((reverse dir) eparse any:(var Str head) "/../" any "/" any:(var Str tail))
            dir := reverse head+"/"+tail
          if (env allowed dir false filename)
            env cwd := dir
            env writeline "257 [dq]"+env:cwd+"[dq] is the new current directory."
          else
            env writeline "530 You are not allowed to access that directory."
      eif (cmd parse word:"PWD")
        plugin command_pwd
          env writeline "257 [dq]"+env:cwd+"[dq] is the current directory."
      eif (cmd parse word:"MKD" any:path)
        plugin command_mkd
          var Str dir := shunt (path 0 1)="/" path env:cwd+path
          if dir="" or (dir dir:len-1)<>"/"
            dir += "/"
          while ((reverse dir) eparse any:(var Str head) "/../" any "/" any:(var Str tail))
            dir := reverse head+"/"+tail
          if (env allowed dir true filename)
            if (file_tree_create filename)=success
              env writeline "257 "+string:path+" created."
            else
              env writeline "550 Could not create the directory."
          else
            env writeline "530 Your are not allowed to access that file."
      eif (cmd parse word:"DELE" any:path)
        plugin command_dele
          if (env allowed path true filename)
            if (file_delete filename)=success
              env writeline "250 file removed."
            else
              env writeline "550 Could not remove the file."
          else
            env writeline "530 Your are not allowed to access that file."
      eif (cmd parse word:"RMD" any:path)
        plugin command_rmd
          var Str dir := shunt (path 0 1)="/" path env:cwd+path
          if dir="" or (dir dir:len-1)<>"/"
            dir += "/"
          while ((reverse dir) eparse any:(var Str head) "/../" any "/" any:(var Str tail))
            dir := reverse head+"/"+tail
          if (env allowed dir true filename)
            if (file_delete filename)=success
              env writeline "250 directory removed."
            else
              env writeline "550 Could not remove the directory."
          else
            env writeline "530 Your are not allowed to access that directory."
      eif (cmd parse word:"LIST" any:path)
        plugin command_list
          var Int details_level := 1
          while (path eparse "-" any:(var Str opt) _ any:(var Str path2)) or { path2 := "" ; path eparse "-" any:(var Str opt) }
            if opt="pliant"
              details_level := max details_level 2
            if opt="extended"
              details_level := max details_level 3
            path := path2
          if (env allowed path false filename)
            ftp_list filename path details_level ftp env
          else
            env writeline "530 You are not allowed to access that directory."
      eif (cmd parse word:"NLST" any:path)
        plugin command_nlst
          if (env allowed path false filename)
            ftp_list filename path 0 ftp env
          else
            env writeline "530 You are not allowed to access that directory."
      eif (cmd parse word:"MDTM" any:path)
        plugin command_mdtm
          if (env allowed path false filename)
            var FileInfo info := file_query filename standard
            if info=failure
              env writeline "550 Failed to open file "+filename
            else
              info:datetime split (var Int year) (var Int month) (var Int day) (var Int hour) (var Int minute) (var Int second) (var Float fraction)
              env writeline "200 "+(right string:year 4 "0")+(right string:month 2 "0")+(right string:day 2 "0")+(right string:hour 2 "0")+(right string:minute 2 "0")+(right string:second 2 "0")
          else
            env writeline "530 Your are not allowed to access that file."
      eif (cmd parse word:"SIZE" any:path)
        plugin command_size
          if (env allowed path false filename)
            var FileInfo info := file_query filename standard
            if info=failure
              env writeline "550 Failed to open file "+filename
            else
              env writeline "200 "+(string info:size)
          else
            env writeline "530 Your are not allowed to access that file."
      eif (cmd parse word:"SYST")
        plugin command_syst
          env writeline "200 Pliant FTP server"+(shunt server:send_software_release_number " release "+string:pliant_release_number "")+(shunt server:unix_style " (Unix style)" "")
      eif (cmd parse word:"TYPE" any:(var Str mode))
        plugin command_type
          if mode="I"
            env writeline "200 Type set to Image."
          eif mode="A"
            env writeline "200 Ascii ignored !"
          else 
            env writeline "504 Only Image type is supported, not "+mode+"."
      eif (cmd parse word:"MODE" any:mode)
        plugin command_mode
          if mode="S"
            env writeline "200 Mode set to Stream."
          else 
            env writeline "504 Only Stream mode is supported."
      eif (cmd parse word:"QUIT")
        plugin command_quit
          env writeline "221 Good bye."
          return
      else
        plugin unknown_command
          env writeline "502 Command not implemented."
  env:log trace "FTP connection stop at " datetime " from " (ftp query "remote_ip_address")


define_tcp_server FtpServer ftp_server
export ftp_server