/pliant/protocol/ftp/server.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  abstract 
 17    [This is Pliant FTP server implementation (RFC 959)] 
 18   
 19  module "/pliant/install/minimal.pli" 
 20  module "/pliant/language/unsafe.pli" 
 21  module "/pliant/language/context.pli" 
 22  module "/pliant/language/compiler.pli" 
 23  module "/pliant/language/stream.pli" 
 24  module "/pliant/admin/file.pli" 
 25  module "/pliant/admin/md5.pli" 
 26  submodule "/pliant/protocol/common/tcp_server.pli" 
 27  module "/pliant/protocol/common/misc.pli" 
 28  module "/pliant/protocol/http/site.pli" 
 29  module "/pliant/fullpliant/user.pli" 
 30  module "/pliant/fullpliant/login.pli" 
 31  module "/pliant/language/os/socket.pli" 
 32   
 33   
 34  constant passive true 
 35  constant active true 
 36   
 37  (gvar TraceSlot ftp_trace) configure "FTP server" 
 38   
 39   
 40  public 
 41    type FtpServer 
 42      tcp_server_fields "FTP" 21 
 43      field CBool send_software_release_number <- true 
 44      field CBool unix_style <- true 
 45  TcpServer maybe FtpServer 
 46   
 47  type FtpEnv 
 48    field Pointer:FtpServer server 
 49    field Link:Stream command 
 50    field Stream data 
 51    field Data:Site site 
 52    field Str user <- "" ; field Int user_auth_level <- 0 
 53    field Dictionary rights 
 54    field Str port 
 55    field Str cwd <- "/" 
 56    field TraceSession log 
 57    
 58   
 59  method env writeline line 
 60    arg_rw FtpEnv env ; arg Str line 
 61    env:command writeline line 
 62    env:log trace "answer " line 
 63   
 64  method env try_site site -> status 
 65    arg_rw FtpEnv env ; arg Data:Site site ; arg Status status 
 66    if not exists:site 
 67      return failure 
 68    if site:computer<>computer_fullname and site:computer<>"" 
 69      return failure 
 70    if site:protocol<>"FTP" 
 71      return failure 
 72    var Str ip := env:command query "local_ip_address" 
 73    if ip<>"" and site:ip<>ip and site:ip<>"" 
 74      return failure 
 75    if ((env:command query "local_ip_port") parse (var Int port)) and site:port<>port and site:port=defined 
 76      return failure 
 77    env:log trace "site is " keyof:site 
 78    env site :> site 
 79    status := success 
 80   
 81  method env assign_rights uname ip rights 
 82    arg_rw FtpEnv env ; arg Str uname ip ; arg_rw Str rights 
 83    var Data:User u :> user uname 
 84    each r u:right 
 85      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)) 
 86        env:rights kmap r:right CBool := true 
 87        rights += " "+r:right 
 88   
 89  method env assign_user 
 90    arg_rw FtpEnv env 
 91    env rights := var Dictionary empty_dictionary 
 92    var Str ruser := env:command safe_query "remote_user" 
 93    if ruser<>"" 
 94      env user := ruser 
 95      env user_auth_level := 3 
 96      env site :> site (env:command safe_query "local_user") 
 97    else 
 98      part scan_for_site 
 99        each s site 
 100          if s:protocol="FTP" and (s:computer<>"" or s:ip<>"") 
 101            if (env try_site s)=success 
 102              leave scan_for_site 
 103        each s site 
 104          if s:ip<>"" 
 105            if (env try_site s)=success 
 106              leave scan_for_site 
 107        each s site 
 108          if s:computer<>"" 
 109            if (env try_site s)=success 
 110              leave scan_for_site 
 111        each s site 
 112          if (env try_site s)=success 
 113            leave scan_for_site 
 114        return 
 115    var Str rights 
 116    var Str ip := env:command query "remote_ip_address" 
 117    env assign_rights "anonymous" ip rights 
 118    each t (user env:user):template 
 119      env assign_rights t ip rights 
 120    if env:user<>"" 
 121      env assign_rights env:user ip rights 
 122    env:log trace "user " env:user " " env:user_auth_level " :" rights 
 123    if env:user<>"" 
 124      if not (login_record env:user ip "FTP "+(string env:user_auth_level)) 
 125        env user := "" 
 126        env user_auth_level := 0 
 127        env rights := var Dictionary empty_dictionary 
 128   
 129   
 130  method env connect 
 131    arg_rw FtpEnv env 
 132    if env:data:is_open 
 133      var Link:Stream data :> env data 
 134      if ((env:data query "connection_handle") parse (var Int handle)) and (os_socket_wait handle 1 120)=success 
 135        env:data configure "connect" 
 136      else 
 137        env:data error "Timeout on pending FTP connection" 
 138      if (env:data query "remote_ip_address")<>(env:command query "remote_ip_address") 
 139        env:data error "Wrong client connected to pending FTP connection" 
 140    else 
 141      env:data open env:port in+out+safe+cr+lf 
 142   
 143   
 144  method env allowed path1 write filename -> allow 
 145    arg FtpEnv env ; arg Str path1 ; arg CBool write ; arg_w Str filename ; arg CBool allow 
 146    var Data:SiteArea area 
 147    var Str path := shunt (path1 0 1)="/" path1 env:cwd+path1 
 148    var Str ext := path 
 149    ext := ext (ext search_last "/" -1)+1 ext:len 
 150    ext := ext (ext search_last "." ext:len) ext:len 
 151    var Int longuest := 0 
 152    each a env:site:area 
 153      var Str p := a path 
 154      if (path 0 p:len)=p 
 155        var Int l := p len 
 156        if l>longuest 
 157          area :> a 
 158          longuest := l 
 159        eif l=longuest 
 160          area :> var Data:SiteArea nonexisting_area 
 161    if area:root="" 
 162      filename := env:site:root+(path 1 path:len) 
 163    else 
 164      filename := area:root+(path area:path:len path:len) 
 165    var Str cond := shunt write area:write area:read 
 166    allow := cond<>"" and (env:rights first cond)<>null or (env:rights first "administrator")<>null 
 167   
 168   
 169  function ftp_read filename from ftp env 
 170    arg Str filename ; arg Intn from ; arg_rw Stream ftp ; arg_rw FtpEnv env 
 171    var Str real := filename 
 172    plugin read_name 
 173    var Stream file ; file open real in+safe+(shunt from=0 bigcache 0) 
 174    if file=success 
 175      if from<>0 
 176        file configure "seek "+string:from 
 177      env writeline "150 ready to read file "+file:name ; ftp flush async 
 178      env connect 
 179      while not file:atend and env:data<>failure 
 180        var Address adr ; var Int size 
 181        file read_available adr size 
 182        env:data raw_write adr size 
 183      if file:close=success and env:data:close=success 
 184        env writeline "226 File "+file:name+" has been red successfully." 
 185      else 
 186        env writeline "551 Failed to read from disk." 
 187    else 
 188      env writeline "550 Failed to open file "+file:name 
 189     
 190   
 191  function ftp_write filename from ftp env 
 192    arg Str filename ; arg Intn from ; arg_rw Stream ftp ; arg_rw FtpEnv env 
 193    var Str real := filename 
 194    plugin write_name 
 195    var Stream file ; file open real out+safe+(shunt from=0 bigcache 0) 
 196    if file=success 
 197      if from<>0 
 198        file configure "seek "+string:from 
 199      env writeline "150 ready to write file "+file:name ; ftp flush async 
 200      env connect 
 201      while not env:data:atend 
 202        var Address adr ; var Int size 
 203        env:data read_available adr size 
 204        file raw_write adr size 
 205      if file:close=success and env:data:close=success 
 206        env writeline "226 File "+file:name+" has been written successfully." 
 207      else 
 208        env writeline "551 Failed to write to disk." 
 209    else 
 210      env writeline "550 Failed to open file "+file:name 
 211     
 212   
 213  function ftp_list filename original_name details_level ftp env 
 214    arg Str filename original_name ; arg Int details_level ; arg_rw Stream ftp ; arg_rw FtpEnv env 
 215    env writeline "150 "+(repeat 60 "-") ; ftp flush async 
 216    var Str real := filename 
 217    var Str f := shunt (original_name 0 1)="/" original_name env:cwd+original_name 
 218    if f:len>=4 and (f f:len-4 4)="/*.*" 
 219      real := real 0 real:len-3 ; f := f 0 f:len-3 
 220    eif f:len>=2 and (f f:len-2 2)="/*" 
 221      real := real 0 real:len-1 ; f := f 0 f:len-1 
 222    if f:len=0 or (f f:len-1)<>"/" 
 223      real += "/" ; f += "/" 
 224    plugin list_name 
 225    var Array:FileInfo files := file_list real (shunt details_level>2 extended standard)+relative+directories 
 226    var Dictionary known ; var CBool computed := false 
 227    each a env:site:area 
 228      if (a:path 0 f:len)=f and a:root<>"" 
 229        var Str sub := a:path f:len a:path:len 
 230        if (sub search_last "/" -2)=sub:len-1 
 231          if not computed 
 232            for (var Int i) 0 files:size-1 
 233              known insert files:i:name true addressof:void 
 234            computed := true 
 235          if (known first sub)=null 
 236            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 
 237            extra name := sub 
 238            files += extra 
 239    if files:size=0 and filename:len<>0 and (filename real:len-1)<>"/" 
 240      var FileInfo file := file_query filename extended+relative 
 241      if file=defined 
 242        file name := file name_without_path 
 243        files += file 
 244    plugin list_content 
 245    env connect 
 246    for (var Int i) 0 files:size-1 
 247      if details_level>0 
 248        var Str l 
 249        if (env:server:unix_style and details_level<2) 
 250          l := (shunt files:i:is_directory "d" "-")+"rwxrwxrwx" 
 251          # var Int mode := files:i:options option "mode" Int 
 252          # if mode=undefined 
 253          #   mode := 0 
 254          # for (var Int j) 8 0 step -1 
 255          #   l += shunt (mode .and. 2^j)<>0 "xwr":(j%3) "-" 
 256          l += "   0 any      any  "+(right (string files:i:size) 12 " ") 
 257          var Int year month day hour minute second ; var Float fraction 
 258          var DateTime dt := files:i:datetime 
 259          if dt=undefined 
 260            dt := datetime 
 261          dt split year month day hour minute second fraction 
 262          # var Str d := day_name files:i:datetime:day_of_week 
 263          # l += " "+upper:(d 0 1)+(d 1 2) 
 264          l += " "+("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec" (month-1)*4 3) 
 265          l += " "+(right string:day 2 " ") 
 266          if false 
 267            l += " "+(right string:hour 2 "0") 
 268            l += ":"+(right string:minute 2 "0") 
 269            # l += ":"+(right string:second 2 "0") 
 270          else 
 271            l += " "+(right string:year 5 " ") 
 272          l += " "+(shunt files:i:is_directory (files:i:name 0 files:i:name:len-1) files:i:name) 
 273          plugin list_unix_file 
 274        else 
 275          var Str opt := string files:i:options 
 276          opt := (shunt opt:len>2 " " "")+(opt 1 opt:len-2) 
 277          l := (left (string files:i:name) 42 " ")+" "+(right (string files:i:size) 12 " ")+" "+(string files:i:datetime)+opt 
 278          plugin list_pliant_file 
 279        env:data writeline l 
 280        env:log trace "list " l 
 281      else 
 282        env:data writeline files:i:name 
 283        env:log trace "list " files:i:name 
 284    env:data close 
 285    env writeline "226 "+(repeat 60 "-") 
 286   
 287   
 288  method server service ftp 
 289    arg_rw FtpServer server ; arg_rw Stream ftp 
 290    var FtpEnv env 
 291    env:log bind ftp_trace 
 292    env server :> server 
 293    env command :> ftp 
 294    env assign_user 
 295    env:log trace "FTP connection start at " datetime " from " (ftp query "remote_ip_address") 
 296    ftp writeline "220 Welcome to Pliant FTP server" 
 297    env:log trace "welcome 220 Welcome to Pliant FTP server" 
 298    var Str user_name 
 299    part dialog 
 300      while not ftp:atend 
 301        var Str cmd := ftp readline 
 302        env:log trace "query " cmd 
 303        if (plugin condition false) 
 304          plugin action 
 305        eif (cmd parse word:"USER" any:user_name) 
 306          plugin command_user 
 307            env writeline "331 User name okay, need password." 
 308        eif (cmd parse word:"PASS" any:(var Str password)) 
 309          plugin command_pass 
 310            var Data:UserSecret u :> user_secret_database:data:user user_name 
 311            if (plugin login string_md5_hexa_signature:password=u:password_md5) 
 312              env user := user_name ; env:user_auth_level := 1 ; env assign_user 
 313              env writeline "230 User logged in." 
 314            eif user_name="" or user_name="anonymous" 
 315              env writeline "230 User logged in." 
 316            else 
 317              sleep 1 
 318              env writeline "531 Bad password for "+user_name 
 319          plugin login 
 320        eif (cmd parse word:"PORT" (var Int i1) "," (var Int i2) "," (var Int i3) "," (var Int i4) "," (var Int p1) "," (var Int p2)) 
 321          plugin command_port 
 322            if passive and env:data:is_open 
 323              env writeline "200 ok" 
 324            eif active 
 325              (ftp query "remote_ip_address") parse (var Int j1) "." (var Int j2) "." (var Int j3) "." (var Int j4) 
 326              if j1=i1 and j2=i2 and j3=i3 and j4=i4 
 327                env port := "tcp://"+string:i1+"."+string:i2+"."+string:i3+"."+string:i4+"/client/"+(string p1*256+p2) 
 328                env writeline "200 ok" 
 329              else 
 330                env port := "" 
 331                env writeline "500 Illegal PORT command." 
 332            else 
 333              env port := "" 
 334              env writeline "500 Illegal PORT command." 
 335        eif passive and (cmd parse word:"PASV") 
 336          plugin command_passive 
 337            env:data open "tcp:/server/any" "noautoconnect" in+out+safe+cr+lf 
 338            (env:data query "local_ip_port") parse (var Int port) 
 339            env writeline "227 Entering Passive Mode. ("+(replace (ftp query "local_ip_address") "." ",")+","+(string port\256)+","+(string port%256)+")" 
 340        eif (cmd parse word:"RETR" any:(var Str path)) 
 341          plugin command_retr 
 342            if (env allowed path false (var Str filename)) 
 343              ftp_read filename 0 ftp env 
 344            else 
 345              env writeline "530 Your are not allowed to access that file." 
 346        eif (cmd parse word:"STOR" any:path) 
 347          plugin command_stor 
 348            if (env allowed path true filename) 
 349              ftp_write filename 0 ftp env 
 350            else 
 351              env writeline "530 Your are not allowed to access that file." 
 352        eif (cmd parse word:"CWD" any:path) or (cmd parse word:"CDUP") 
 353          plugin command_cwd 
 354            var Str dir 
 355            if (cmd parse word:"CDUP")  
 356              dir := shunt env:cwd="/" "/" env:cwd+"../" 
 357            else 
 358              dir := shunt (path 0 1)="/" path env:cwd+path 
 359              if dir="" or (dir dir:len-1)<>"/" 
 360                dir += "/" 
 361            while ((reverse dir) eparse any:(var Str head) "/../" any "/" any:(var Str tail)) 
 362              dir := reverse head+"/"+tail 
 363            if (env allowed dir false filename) 
 364              env cwd := dir 
 365              env writeline "257 [dq]"+env:cwd+"[dq] is the new current directory." 
 366            else 
 367              env writeline "530 You are not allowed to access that directory." 
 368        eif (cmd parse word:"PWD") 
 369          plugin command_pwd 
 370            env writeline "257 [dq]"+env:cwd+"[dq] is the current directory." 
 371        eif (cmd parse word:"MKD" any:path) 
 372          plugin command_mkd 
 373            var Str dir := shunt (path 0 1)="/" path env:cwd+path 
 374            if dir="" or (dir dir:len-1)<>"/" 
 375              dir += "/" 
 376            while ((reverse dir) eparse any:(var Str head) "/../" any "/" any:(var Str tail)) 
 377              dir := reverse head+"/"+tail 
 378            if (env allowed dir true filename) 
 379              if (file_tree_create filename)=success 
 380                env writeline "257 "+string:path+" created." 
 381              else 
 382                env writeline "550 Could not create the directory." 
 383            else 
 384              env writeline "530 Your are not allowed to access that file." 
 385        eif (cmd parse word:"DELE" any:path) 
 386          plugin command_dele 
 387            if (env allowed path true filename) 
 388              if (file_delete filename)=success 
 389                env writeline "250 file removed." 
 390              else 
 391                env writeline "550 Could not remove the file." 
 392            else 
 393              env writeline "530 Your are not allowed to access that file." 
 394        eif (cmd parse word:"RMD" any:path) 
 395          plugin command_rmd 
 396            var Str dir := shunt (path 0 1)="/" path env:cwd+path 
 397            if dir="" or (dir dir:len-1)<>"/" 
 398              dir += "/" 
 399            while ((reverse dir) eparse any:(var Str head) "/../" any "/" any:(var Str tail)) 
 400              dir := reverse head+"/"+tail 
 401            if (env allowed dir true filename) 
 402              if (file_delete filename)=success 
 403                env writeline "250 directory removed." 
 404              else 
 405                env writeline "550 Could not remove the directory." 
 406            else 
 407              env writeline "530 Your are not allowed to access that directory." 
 408        eif (cmd parse word:"LIST" any:path) 
 409          plugin command_list 
 410            var Int details_level := 1 
 411            while (path eparse "-" any:(var Str opt) _ any:(var Str path2)) or { path2 := "" ; path eparse "-" any:(var Str opt) } 
 412              if opt="pliant" 
 413                details_level := max details_level 2 
 414              if opt="extended" 
 415                details_level := max details_level 3 
 416              path := path2 
 417            if (env allowed path false filename) 
 418              ftp_list filename path details_level ftp env 
 419            else 
 420              env writeline "530 You are not allowed to access that directory." 
 421        eif (cmd parse word:"NLST" any:path) 
 422          plugin command_nlst 
 423            if (env allowed path false filename) 
 424              ftp_list filename path 0 ftp env 
 425            else 
 426              env writeline "530 You are not allowed to access that directory." 
 427        eif (cmd parse word:"MDTM" any:path) 
 428          plugin command_mdtm 
 429            if (env allowed path false filename) 
 430              var FileInfo info := file_query filename standard 
 431              if info=failure 
 432                env writeline "550 Failed to open file "+filename 
 433              else 
 434                info:datetime split (var Int year) (var Int month) (var Int day) (var Int hour) (var Int minute) (var Int second) (var Float fraction) 
 435                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") 
 436            else 
 437              env writeline "530 Your are not allowed to access that file." 
 438        eif (cmd parse word:"SIZE" any:path) 
 439          plugin command_size 
 440            if (env allowed path false filename) 
 441              var FileInfo info := file_query filename standard 
 442              if info=failure 
 443                env writeline "550 Failed to open file "+filename 
 444              else 
 445                env writeline "200 "+(string info:size) 
 446            else 
 447              env writeline "530 Your are not allowed to access that file." 
 448        eif (cmd parse word:"SYST") 
 449          plugin command_syst 
 450            env writeline "200 Pliant FTP server"+(shunt server:send_software_release_number " release "+string:pliant_release_number "")+(shunt server:unix_style " (Unix style)" "") 
 451        eif (cmd parse word:"TYPE" any:(var Str mode)) 
 452          plugin command_type 
 453            if mode="I" 
 454              env writeline "200 Type set to Image." 
 455            eif mode="A" 
 456              env writeline "200 Ascii ignored !" 
 457            else  
 458              env writeline "504 Only Image type is supported, not "+mode+"." 
 459        eif (cmd parse word:"MODE" any:mode) 
 460          plugin command_mode 
 461            if mode="S" 
 462              env writeline "200 Mode set to Stream." 
 463            else  
 464              env writeline "504 Only Stream mode is supported." 
 465        eif (cmd parse word:"QUIT") 
 466          plugin command_quit 
 467            env writeline "221 Good bye." 
 468            return 
 469        else 
 470          plugin unknown_command 
 471            env writeline "502 Command not implemented." 
 472    env:log trace "FTP connection stop at " datetime " from " (ftp query "remote_ip_address") 
 473   
 474   
 475  define_tcp_server FtpServer ftp_server 
 476  export ftp_server 
 477