/pliant/protocol/ftp/client.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  module "/pliant/language/unsafe.pli" 
 17  module "/pliant/language/context.pli" 
 18  module "/pliant/language/stream.pli" 
 19  module "/pliant/language/stream/filesystembase.pli" 
 20  module "/pliant/language/stream/openmode.pli" 
 21  module "/pliant/language/stream/listmode.pli" 
 22  module "/pliant/language/stream/multi.pli" 
 23   
 24   
 25  constant ftp_auto_deconnect_after 30 
 26   
 27  (gvar TraceSlot ftp_trace) configure "FTP client" 
 28   
 29   
 30 
 
 31  # connections pool to ftp servers 
 32   
 33   
 34  gvar List connections_list 
 35  gvar Dictionary connections_hash 
 36  gvar Sem csem 
 37  gvar CBool auto_deconnect_running := false 
 38   
 39   
 40  type FtpConnection 
 41    field Stream command_stream 
 42    field TraceSession log 
 43    field Str host user syst ; field Int port 
 44    field CBool inuse 
 45    field DateTime keepuntil  
 46    field Str data_stream_name 
 47    field Stream data_stream  
 48    field CBool passive <- true 
 49   
 50   
 51  method ftp command cmd  
 52    arg_rw FtpConnection ftp ; arg Str cmd 
 53    ftp:command_stream writeline cmd 
 54    ftp:command_stream flush anytime 
 55    ftp:log trace "query " cmd 
 56   
 57  method ftp status -> s 
 58    arg_rw FtpConnection ftp ; arg Int s 
 59    var Str ack := ftp:command_stream readline 
 60    ftp:log trace "answer " ack 
 61    if (ack 3 1)="-" 
 62      var Str code := ack 0 3 
 63      var CBool done := false 
 64      while not done 
 65        ack := ftp:command_stream readline 
 66        ftp:log trace "answer " ack 
 67        done := (ack 0 4)=code+" " 
 68    if not ((ack 0 3) parse s) 
 69      := 599 
 70     
 71  method ftp status2 -> s 
 72    arg_rw FtpConnection ftp ; arg Str s 
 73    := ftp:command_stream readline 
 74    ftp:log trace "answer " s 
 75     
 76   
 77  method ftp open_data_stream 
 78    arg_rw FtpConnection ftp 
 79    if ftp:passive 
 80      ftp command "PASV" 
 81      var Str := ftp status2 
 82      var Int i1 i2 i3 i4 p1 p2 
 83      if (parse any "(" i1 "," i2 "," i3 "," i4 "," p1 "," p2 ")" any) 
 84        ftp data_stream_name := "tcp://"+string:i1+"."+string:i2+"."+string:i3+"."+string:i4+"/client/"+(string p1*256+p2) 
 85      else 
 86        ftp data_stream_name := "" 
 87        ftp passive := false 
 88    if not ftp:passive 
 89      ftp:data_stream open "tcp:/server/any" "noautoconnect" in+out+safe 
 90      var Str ip_address := ftp:command_stream query "local_ip_address" 
 91      (ftp:data_stream query "local_ip_port"parse (var Int ip_port) 
 92      ftp command "PORT "+(replace ip_address "." ",")+","+(string ip_port\256)+","+(string ip_port%256) 
 93      if ftp:status>=500 
 94        ftp:data_stream close 
 95     
 96  method ftp connect_data_stream1 
 97    arg_rw FtpConnection ftp 
 98    if ftp:passive 
 99      ftp:data_stream open ftp:data_stream_name in+out+safe 
 100       
 101  method ftp connect_data_stream2 
 102    arg_rw FtpConnection ftp 
 103    if not ftp:passive 
 104      ftp:data_stream safe_configure "connect" 
 105       
 106  method ftp close_data_stream 
 107    arg_rw FtpConnection ftp 
 108    ftp:data_stream close 
 109     
 110   
 111 
 
 112   
 113   
 114  function connect host port user password reuse -> cc 
 115    arg Str host ; arg Int port ; arg Str user password ; arg CBool reuse ; arg Link:FtpConnection cc 
 116    if reuse 
 117      csem request 
 118      var Str key := host+" "+user 
 119      var Pointer:Arrow cur :> connections_hash first key 
 120      while cur<>null 
 121        var Pointer:FtpConnection :> cur map FtpConnection 
 122        if c:host=host and c:port=port and c:user=user and not c:inuse 
 123          inuse := true 
 124          cc :> c 
 125          csem release 
 126          return 
 127        cur :> connections_hash next key cur 
 128      csem release 
 129    cc :> new FtpConnection 
 130    cc:log bind ftp_trace 
 131    cc:command_stream open "tcp://"+host+"/client/"+string:port in+out+safe+cr+lf 
 132    cc status 
 133    if user<>"" 
 134      cc command "USER "+user ; cc status 
 135    if password<>"" 
 136      cc command "PASS "+password ; cc status 
 137    cc command "TYPE I" ; cc status 
 138    if cc:command_stream=failure 
 139      cc :> null map FtpConnection 
 140      return 
 141    cc host := host 
 142    cc port := port 
 143    cc user := user 
 144    cc inuse := true 
 145    if reuse 
 146      csem request 
 147      connections_hash insert key true addressof:cc 
 148      connections_list append addressof:cc 
 149      if not auto_deconnect_running 
 150        auto_deconnect_running := true 
 151        thread 
 152          var CBool continue := true 
 153          while continue 
 154            sleep 15 
 155            csem request 
 156            var Pointer:Arrow cur :> connections_list first 
 157            if cur<>null 
 158              var DateTime now := datetime 
 159              while cur<>null 
 160                var Pointer:FtpConnection :> cur map FtpConnection 
 161                if not c:inuse and now>=c:keepuntil 
 162                  connections_hash remove c:host+" "+c:user cur 
 163                  cur :> connections_list remove cur 
 164                else 
 165                  cur :> connections_list next cur 
 166            else 
 167              continue := false 
 168              auto_deconnect_running := false 
 169            csem release 
 170      csem release 
 171   
 172   
 173  function deconnect ftp 
 174    arg_rw FtpConnection ftp 
 175    ftp:log flush 
 176    csem rd_request 
 177    ftp:keepuntil seconds := datetime:seconds ftp_auto_deconnect_after 
 178    ftp inuse := false 
 179    csem rd_release 
 180   
 181   
 182 
 
 183   
 184   
 185  type FtpStreamDriver 
 186    field Link:FtpConnection connection 
 187    field Link:StreamDriver socket 
 188  StreamDriver maybe FtpStreamDriver 
 189   
 190   
 191  method ftp read buf mini maxi -> red 
 192    arg_rw FtpStreamDriver ftp ; arg Address buf ; arg Int mini maxi red 
 193    red := ftp:socket read buf mini maxi 
 194   
 195   
 196  method ftp write buf mini maxi -> written 
 197    arg_rw FtpStreamDriver ftp ; arg Address buf ; arg Int mini maxi written 
 198    written := ftp:socket write buf mini maxi 
 199   
 200   
 201  method ftp flush level -> status 
 202    arg_rw FtpStreamDriver ftp ; arg Int level ; arg Status status 
 203    status := ftp:socket flush level 
 204   
 205   
 206  method ftp close -> status 
 207    arg_rw FtpStreamDriver ftp ; arg ExtendedStatus status 
 208    ftp socket :> null map StreamDriver 
 209    ftp:connection close_data_stream 
 210    status := shunt ftp:connection:status<400 success failure 
 211    deconnect ftp:connection 
 212   
 213   
 214 
 
 215   
 216   
 217  type FtpFileSystem 
 218    void 
 219  FileSystem maybe FtpFileSystem 
 220   
 221   
 222  function list name sub options flags files 
 223    arg Str name sub options ; arg Int flags ; arg_rw List files 
 224    if (name parse "//" any:(var Str server) "/" any:(var Str path)) 
 225      path := "/"+path 
 226    eif (name parse "/" any:(var Str path)) 
 227      server := "localhost" ; path := "/"+path 
 228    else 
 229      return 
 230    var Int port 
 231    if (server eparse any:(var Str server1) ":" port) 
 232      server := server1 
 233    else 
 234      port := 21 
 235    var Str user := options option "user" Str 
 236    var Str password := options option "password" Str 
 237    if not (options option "user") 
 238      user := "anonymous" 
 239    if not (options option "password") 
 240      password := computer_name+"@"+computer_domain 
 241    var CBool eccentric := options option "eccentric" 
 242    var CBool lowercase := options option "lower" 
 243    var Link:FtpConnection ftp :> connect server port user password not (options option "no_connection_cache") 
 244    if not exists:ftp 
 245      return 
 246    if ftp:syst="" 
 247      ftp command "SYST" 
 248      var Str syst := lower ftp:status2 
 249      if syst="200 pliant ftp server version 1.00" 
 250        ftp syst := "Pliant OS/2" 
 251      eif (syst parse word:"200" word:"pliant" word:"ftp" word:"server" any) 
 252        ftp syst := "Pliant" 
 253      eif (syst search "unix" -1)>=0 
 254        ftp syst := "Unix" 
 255      else 
 256        ftp syst := "Unknown" 
 257    ftp command "CWD "+path 
 258    if ftp:status>=400 
 259      return 
 260    var List names info 
 261    ftp open_data_stream 
 262    if not eccentric                      
 263      ftp command "LIST"+(shunt ftp:syst="Pliant" and (flags .and. extended)<>" -extended" ftp:syst="Unix" " -A --full-time" "")+(shunt sub<>"" " "+sub "") 
 264      ftp connect_data_stream1 
 265      if ftp:status>=400 
 266        ftp close_data_stream 
 267        deconnect ftp 
 268        return 
 269      ftp connect_data_stream2 
 270      while not (ftp:data_stream atend) 
 271        var Str := ftp:data_stream readline 
 272        ftp:log trace "list " l 
 273        var Str filename dir rights ascii_month opt 
 274        var Intn size ; var DateTime dt1 
 275        var Int year month day hour minute second 
 276        if ftp:syst="Pliant" and (parse filename size dt1 any:opt) 
 277          var Link:FileInfo :> new FileInfo 
 278          name := name+filename 
 279          size := size 
 280          datetime := dt1 
 281          if ("[dq]"+opt+"[dq]" parse (var Str opt2)) 
 282            options := opt2 
 283          status := success 
 284          files append addressof:f 
 285        if ftp:syst="Unix" and (parse any:rights _ any _ any _ any _ size _ any _ any:ascii_month day hour ":" minute ":" second year _ any:filename) 
 286          if filename<>"./" and filename<>"../" 
 287            var Link:FileInfo :> new FileInfo 
 288            if (filename parse any:(var Str filename1) "->" any:(var Str link)) 
 289              filename := filename1 
 290              if link:len>and (link link:len-1 1)="/" 
 291                filename := filename+"/" 
 292              options := "link "+string:link 
 293            if filename:len>and (filename filename:len-1 1)="*" 
 294              filename := filename filename:len-1 
 295            name := name+filename 
 296            size := size 
 297            month := ("XXX Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec" search ascii_month 0)\4 
 298            if month>0 
 299              datetime := datetime year month day hour minute second 0 
 300            status := success 
 301            files append addressof:f 
 302        eif ftp:syst="Pliant OS/2" and (parse day "/" month "/" year hour ":" minute ":" second size _ any:filename) 
 303          var Link:FileInfo :> new FileInfo 
 304          if lowercase 
 305            name := shunt (filename parse word:"DIR" any:dir) name+lower:dir+"/" name+lower:filename 
 306          else 
 307            name := shunt (filename parse word:"DIR" any:dir) name+dir+"/" name+filename 
 308          size := size 
 309          datetime := datetime year month day hour minute second 0 
 310          status := success 
 311          files append addressof:f 
 312        eif (parse any:rights _ any _  any _ any _ size _ any:ascii_month day hour ":" minute _ any:filename) or (parse any:rights _ any _  any _ any _ size _ any:ascii_month day year _ any:filename) 
 313          # Unix ls -l format 
 314          if filename<>"." and filename<>".." 
 315            var Link:FileInfo :> new FileInfo 
 316            if (filename parse any:(var Str filename1) "->" any:(var Str link)) 
 317              filename := filename1 
 318              if link:len>and (link link:len-1 1)="/" 
 319                filename := filename+"/" 
 320              options := "link "+string:link 
 321            name := name+filename+(shunt (rights 0 1)="d" "/" "") 
 322            size := size 
 323            status := success 
 324            files append addressof:f 
 325            if not f:is_directory 
 326              names append addressof:(new Str filename) 
 327              info append addressof:f 
 328        else 
 329          ftp:log trace "unsupported listing" 
 330    else 
 331      ftp command "NLST"+(shunt sub<>"" " "+sub "") 
 332      ftp connect_data_stream1 
 333      if ftp:status>=400 
 334        ftp close_data_stream 
 335        deconnect ftp 
 336        return 
 337      ftp connect_data_stream2 
 338      while not (ftp:data_stream atend) 
 339        var Str := ftp:data_stream readline 
 340        var Link:FileInfo :> new FileInfo 
 341        name := name+l 
 342        status := success 
 343        files append addressof:f 
 344        names append addressof:(new Str filename) 
 345        info append addressof:f 
 346    ftp close_data_stream 
 347    ftp status 
 348    var Pointer:Arrow c1 :> names first 
 349    var Pointer:Arrow c2 :> info first 
 350    while c1<>null 
 351      var Pointer:Str name2 :> c1 map Str 
 352      var Pointer:FileInfo info2 :> c2 map FileInfo 
 353      ftp command "MDTM "+path+name2 
 354      if (ftp:status2 parse (var Int retcode) _ any:(var Str dt)) and retcode<400 
 355        if ((dt 0 4) parse year) and ((dt 4 2) parse month) and ((dt 6 2) parse day) and ((dt 8 2) parse hour) and ((dt 10 2) parse minute) and ((dt 12 2) parse second) 
 356          info2 datetime := datetime year month day hour minute second 0 
 357      if eccentric 
 358        ftp command "SIZE "+path+name2 
 359        if (ftp:status2 parse (var Int retcode) size) and retcode<400 
 360          info2 size := size 
 361        ftp command "CWD "+path+name2 
 362        if ftp:status<300 
 363          info2 name += "/" 
 364      c1 :> names next c1   
 365      c2 :> info next c2 
 366    deconnect ftp 
 367   
 368  method fs query name options flags info -> status  
 369    arg_rw FtpFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw FileInfo info ; arg ExtendedStatus status 
 370    var Int := name search_last "/" -1 
 371    list (name i+1) (name i+name:len) options flags (var List files) 
 372    var Pointer:Arrow :> files first 
 373    while c<>null 
 374      if (map FileInfo):name=name 
 375        (map FileInfo) name := info name 
 376        info := map FileInfo 
 377        return success 
 378      :> files next c 
 379    return failure 
 380   
 381  method fs list name options flags files -> supported_flags 
 382    arg_rw FtpFileSystem fs ; arg Str name options ; arg Int flags supported_flags ; arg_rw List files 
 383    supported_flags := 0 
 384    list name "" options flags files 
 385   
 386   
 387  method fs open name options flags stream support -> status 
 388    arg_rw FtpFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status 
 389    if (name parse "//" any:(var Str server) "/" any:(var Str path)) 
 390      path := "/"+path 
 391    eif (name parse "/" any:(var Str path)) 
 392      server := "localhost" ; path := "/"+path 
 393    else 
 394      return failure 
 395    var Int port 
 396    if (server eparse any:(var Str server1) ":" port) 
 397      server := server1 
 398    else 
 399      port := 21 
 400    var Str user := options option "user" Str 
 401    var Str password := options option "password" Str 
 402    if not (options option "user") 
 403      user := "anonymous" 
 404    if not (options option "password") 
 405      password := computer_name+"@"+computer_domain 
 406    if (flags .and. in_out)<>in and (flags .and. in_out)<>out 
 407      return failure 
 408    var Link:FtpConnection ftp :> connect server port user password not (options option "no_connection_cache") 
 409    if not exists:ftp 
 410      return failure 
 411    ftp passive := not (options option "active") 
 412    ftp open_data_stream 
 413    ftp command (shunt (flags .and. in_out)=in "RETR " "STOR ")+path 
 414    ftp connect_data_stream1 
 415    if ftp:status<400 
 416      ftp connect_data_stream2 
 417      var Link:FtpStreamDriver drv :> new FtpStreamDriver 
 418      drv connection :> ftp 
 419      drv socket :> ftp:data_stream:stream_driver 
 420      stream stream_driver :> drv 
 421      stream stream_handle := ftp:data_stream stream_handle 
 422      status := success 
 423    else 
 424      ftp close_data_stream 
 425      deconnect ftp 
 426      status := failure 
 427   
 428   
 429  method fs configure filename options command -> status 
 430    arg_rw FtpFileSystem fs ; arg Str filename options command ; arg ExtendedStatus status 
 431    if (filename parse "//" any:(var Str server) "/" any:(var Str path)) 
 432      path := "/"+path 
 433    eif (filename parse "/" any:(var Str path)) 
 434      server := "localhost" ; path := "/"+path 
 435    else 
 436      return failure 
 437    var Int port 
 438    if (server eparse any:(var Str server1) ":" port) 
 439      server := server1 
 440    else 
 441      port := 21 
 442    var Str user := options option "user" Str 
 443    var Str password := options option "password" Str 
 444    if not (options option "user") 
 445      user := "anonymous" 
 446    if not (options option "password") 
 447      password := computer_name+"@"+computer_domain 
 448    var Link:FtpConnection ftp :> connect server port user password not (options option "no_connection_cache") 
 449    if not exists:ftp 
 450      return failure 
 451    status := success 
 452    var CBool some := false 
 453    if (command option "mkdir") 
 454      some := true 
 455      ftp command "MKD "+path 
 456      if ftp:status>=400 
 457        status := failure 
 458    if (command option "rmdir") 
 459      some := true 
 460      ftp command "RMD "+path 
 461      if ftp:status>=400 
 462        status := failure 
 463    if (command option "delete") 
 464      some := true 
 465      ftp command "DELE "+path 
 466      if ftp:status>=400 
 467        status := failure 
 468    if not some 
 469      status := failure 
 470    deconnect ftp 
 471   
 472   
 473 
 
 474   
 475   
 476  gvar FtpFileSystem ftp_file_system 
 477  pliant_multi_file_system mount "ftp:" "" ftp_file_system 
 478