/pliant/protocol/http/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/multi.pli" 
 20  module "/pliant/language/stream/filesystembase.pli" 
 21  module "/pliant/language/stream/openmode.pli" 
 22  module "/pliant/language/stream/flushmode.pli" 
 23  module "/pliant/language/stream/listmode.pli" 
 24  module "/pliant/util/encoding/html.pli" 
 25  module "/pliant/util/encoding/date.pli" 
 26  module "/pliant/util/encoding/http.pli" 
 27  module "/pliant/util/encoding/base64.pli" 
 28  module "/pliant/admin/file.pli" 
 29   
 30  constant potencial_timeout 45 
 31  constant debug false 
 32   
 33   
 34  (gvar TraceSlot http_trace) configure "HTTP client" 
 35   
 36  method tcp readline log -> l 
 37    arg_rw Stream tcp ; arg_rw TraceSession log ; arg Str l 
 38    := tcp readline 
 39    if l<>"" 
 40      log trace "answer " l 
 41   
 42  method tcp writeline l log 
 43    arg_rw Stream tcp ; arg Str l ; arg_rw TraceSession log 
 44    tcp writeline l 
 45    log trace "query " l 
 46   
 47  function write_http_options server options tcp log 
 48    arg Str server options ; arg_rw Stream tcp ; arg_rw TraceSession log 
 49    if server<>"" 
 50      tcp writeline "Host: "+server log 
 51    var Str browser := options option "browser" Str "Pliant/"+string:pliant_release_number 
 52    tcp writeline "User-Agent: "+browser log 
 53    if (options option "user" Str)<>"" 
 54      tcp writeline "Authorization: Basic "+(base64_encode (options option "user" Str)+":"+(options option "password" Str)) log 
 55    if (options option "form") 
 56      tcp writeline "Content-Length: "+(string (options option "form" Str):len) 
 57    tcp writeline "" 
 58   
 59   
 60  type HttpFileSystem 
 61    void 
 62  FileSystem maybe HttpFileSystem 
 63   
 64  type HttpStreamDriver 
 65    field Link:Stream tcp 
 66    field CBool direct 
 67    field Intn remain 
 68    field Str filename 
 69    field Link:Stream temp 
 70    field CBool initial_ack 
 71    field Str server path ; field DateTime datetime ; field Str options 
 72    field DateTime opened_on 
 73    field TraceSession log 
 74    field Str mime 
 75  StreamDriver maybe HttpStreamDriver 
 76   
 77  method http read buf mini maxi -> red 
 78    arg_rw HttpStreamDriver http ; arg Address buf ; arg Int mini maxi red 
 79    if (exists http:temp) 
 80      red := 0 
 81    eif http:tcp:stream_read_cur<>http:tcp:stream_read_stop 
 82      red := min (cast http:tcp:stream_read_stop Int).-.(cast http:tcp:stream_read_cur Int) maxi 
 83      memory_copy http:tcp:stream_read_cur buf red 
 84      http:tcp:stream_read_cur := http:tcp:stream_read_cur translate Byte red 
 85    else 
 86      red := http:tcp:stream_driver read buf mini maxi 
 87   
 88  method http write buf mini maxi -> written 
 89    arg_rw HttpStreamDriver http ; arg Address buf ; arg Int mini maxi written 
 90    if http:direct 
 91      if http:remain>=maxi 
 92        written := maxi 
 93      eif http:remain>=mini 
 94        written := http remain 
 95      else 
 96        written := 0 
 97      if debug 
 98        console "try to write " written "/" maxi " remaining " http:remain 
 99      http:tcp raw_write buf written 
 100      if http:tcp=failure 
 101        written := 0 
 102      http remain -= written 
 103      if debug 
 104        console " -> " written eol 
 105    eif (exists http:temp) 
 106      http:temp raw_write buf maxi 
 107      written := shunt http:temp=success maxi 0 
 108    else 
 109      written := 0 
 110   
 111  method http flush level -> status 
 112    arg_rw HttpStreamDriver http ; arg Int level ; arg Status status 
 113    http:tcp flush level 
 114    status := success 
 115   
 116  method http write_header size tcp log -> status 
 117    arg_rw HttpStreamDriver http ; arg Intn size ; arg_rw Stream tcp ; arg_rw TraceSession log ; arg ExtendedStatus status 
 118    var Str option := http:options option "option" Str 
 119    tcp writeline "PUT /"+http:path+(shunt option<>"" "?"+option "")+" HTTP/1.0" log 
 120    tcp writeline "Host: "+http:server log 
 121    tcp writeline "Content-Length: "+string:size log 
 122    if http:datetime=defined 
 123      tcp writeline "Last-Modified: "+(rfc1123_date http:datetime) log 
 124    var Str p_opt := "" 
 125    if (http:options option "mode") 
 126      p_opt += "mode "+string:(http:options option "mode" Int) 
 127    if (http:options option "uid") 
 128      p_opt += " uid "+string:(http:options option "uid" Int) 
 129    if (http:options option "gid") 
 130      p_opt += " gid "+string:(http:options option "gid" Int) 
 131    if p_opt<>"" 
 132      tcp writeline "Pliant-Options: "+http_encode:p_opt log 
 133    write_http_options "" http:options tcp log 
 134    if http:initial_ack 
 135      if debug 
 136        console "wait for initial ack" eol 
 137      var Str answer := tcp readline log 
 138      if not (answer parse "HTTP/" (var Float protocol_level) _ (var Int retcode) _ any) or retcode>=300 
 139        return (failure "HTTP server returned initial error "+string:answer) 
 140      if debug 
 141        console "wait for initial options" eol 
 142      while { var Str := tcp readline log ; l<>"" } 
 143        void 
 144      if debug 
 145        console "got initial answer" eol 
 146    status := success 
 147   
 148  method http close -> status 
 149    arg_rw HttpStreamDriver http ; arg ExtendedStatus status 
 150    var Pointer:Stream tcp :> http tcp 
 151    if http:direct 
 152      if debug 
 153        console "close with " http:remain " remaining bytes" eol 
 154      if http:remain<>0 
 155        return failure:"Too fiew bytes written" 
 156    eif (exists http:temp) 
 157      http:temp close 
 158      var FileInfo info := file_query http:filename standard 
 159      if datetime:seconds-http:opened_on:seconds>=potencial_timeout 
 160        tcp open tcp:name in+out+safe+cr+lf 
 161      status := http write_header info:size tcp http:log 
 162      if status=failure 
 163        file_delete http:filename 
 164        return 
 165      (var Stream s) open http:filename in 
 166      while (raw_copy tcp 1 2^24)>0 
 167        void 
 168      close 
 169      file_delete http:filename 
 170    else 
 171      tcp flush end 
 172    if http:direct or (exists http:temp) 
 173      if debug 
 174        console "wait for final ack" eol 
 175      var Str answer := tcp readline http:log 
 176      if not (answer parse "HTTP/" (var Float protocol_level) _ (var Int retcode) _ any) or retcode>=300 
 177        return (failure "HTTP server returned final error "+string:answer) 
 178      if debug  
 179        console "final answer is " answer eol 
 180      if debug 
 181        console "wait for final options" eol 
 182      while { var Str := tcp readline http:log ; l<>"" } 
 183        void 
 184      if debug 
 185        console "got final answer" eol 
 186    status := tcp close 
 187    if debug 
 188      console "http client done: " (shunt status=success "ok" "failed") eol 
 189   
 190  method http query command stream answer -> status 
 191    arg_rw HttpStreamDriver http ; arg Str command ; arg_rw Stream stream ; arg_w Str answer ; arg ExtendedStatus status  
 192    if command="mime" 
 193      answer := http mime ; status := success 
 194    else 
 195      status := http:tcp:stream_driver query command http:tcp answer 
 196   
 197  method http configure command stream -> status 
 198    arg_rw HttpStreamDriver http ; arg Str command ; arg_rw Stream stream ; arg ExtendedStatus status 
 199    status := http:tcp:stream_driver configure command http:tcp 
 200   
 201  method fs query name options flags info -> status  
 202    arg_rw HttpFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw FileInfo info ; arg ExtendedStatus status 
 203    if (name eparse "//" any:(var Str server) "/" any:(var Str path)) 
 204      void 
 205    else 
 206      return failure 
 207    var Int port 
 208    if (server eparse any:(var Str server1) ":" port) 
 209      server := server1 
 210    else 
 211      port := 80 
 212    var Str channel := options option "channel" Str 
 213    if channel="" 
 214      channel := "tcp://"+server+"/client/"+string:port 
 215    var Link:Stream tcp :> new Stream 
 216    tcp open channel in+out+safe+cr+lf 
 217    if tcp=failure 
 218      http_trace trace "Failed to connect to " channel 
 219      return failure 
 220    (var TraceSession log) bind http_trace 
 221    tcp writeline "HEAD /"+path+" HTTP/1.0" log 
 222    write_http_options server options tcp log 
 223    if not ((tcp readline log) parse "HTTP/" (var Float protocol_level) _ (var Int retcode) _ any) or retcode>=300 
 224      tcp open "tcp://"+server+"/client/"+string:port in+out+safe+cr+lf 
 225      tcp writeline "GET /"+path+" HTTP/1.0" log 
 226      write_http_options server options tcp log 
 227      if not ((tcp readline log) parse "HTTP/" (var Float protocol_level) _ (var Int retcode) _ any) or retcode>=300 
 228        return failure 
 229    while { var Str := tcp readline log ; l<>"" } 
 230      if (parse "Content-Length" ":" (var Intn length)) 
 231        info size := length 
 232      eif (parse "Last-Modified" ":" any "," (var Int day) _ any:(var Str ascii_month) _ (var Int year) _ (var Int hour) ":" (var Int minute) ":" (var Int second) any) 
 233        var Int month := ("XXX Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec" search ascii_month 0)\4 
 234        if month>0 
 235          info datetime := datetime year month day hour minute second 0 
 236    status := success 
 237   
 238   
 239  method fs list epath options flags files -> supported_flags 
 240    oarg_rw HttpFileSystem fs ; arg Str epath options ; arg Int flags supported_flags ; arg_rw List files 
 241    supported_flags := extended 
 242    if (epath eparse "//" any:(var Str server) "/" any:(var Str path)) 
 243      void 
 244    else 
 245      return 
 246    if not (options option "no_http_encode") 
 247      path := http_encode path 
 248    var Int port 
 249    if (server eparse any:(var Str server1) ":" port) 
 250      server := server1 
 251    else 
 252      port := 80 
 253    var Str channel := options option "channel" Str 
 254    if channel="" 
 255      channel := "tcp://"+server+"/client/"+string:port 
 256    var Link:Stream tcp :> new Stream 
 257    tcp open channel in+out+safe+cr+lf 
 258    if tcp=failure 
 259      http_trace trace "Failed to connect to " channel 
 260      return failure 
 261    (var TraceSession log) bind http_trace 
 262    tcp writeline "GET /"+path+"?list HTTP/1.0" log 
 263    write_http_options server options tcp log 
 264    if not ((tcp readline log) parse "HTTP/" (var Float protocol_level) _ (var Int retcode) _ any) or retcode>=300 
 265      return 
 266    while { var Str := tcp readline log ; l<>"" } 
 267      void 
 268    while not tcp:atend 
 269      var Str := tcp readline 
 270      if (eparse "<pfile name=[dq]" any:(var Str name) "[dq] size=[dq]" (var Intn size) "[dq] date=[dq]" (var DateTime dt) "[dq] options=[dq]" any:(var Str opt) "[dq] />") 
 271        var Link:FileInfo info :> new FileInfo 
 272        info name := epath+html_decode:name 
 273        info size := size 
 274        info datetime := dt 
 275        info options := html_decode:opt 
 276        info status := success 
 277        files append addressof:info 
 278        log trace "list" string:name " " size " " datetime " " string:options 
 279   
 280   
 281  method fs open name options flags stream support -> status 
 282    arg_rw HttpFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status 
 283    if (name eparse "//" any:(var Str server) "/" any:(var Str path)) 
 284      void 
 285    else 
 286      return failure 
 287    if not (options option "no_http_encode") 
 288      path := http_encode path 
 289    var Int port 
 290    if (server eparse any:(var Str server1) ":" port) 
 291      server := server1 
 292    else 
 293      port := 80 
 294    var Str channel := options option "channel" Str 
 295    if channel="" 
 296      channel := "tcp://"+server+"/client/"+string:port 
 297    var Link:Stream tcp :> new Stream 
 298    tcp open channel in+out+safe+cr+lf 
 299    if tcp=failure 
 300      http_trace trace "Failed to connect to " channel 
 301      return (failure "Failed to connect to "+string:server+" TCP port "+string:port) 
 302    var Link:HttpStreamDriver http :> new HttpStreamDriver 
 303    http tcp :> tcp 
 304    http direct := false 
 305    http initial_ack := options option "http_initial_ack" 
 306    http server := server+(shunt port=80 "" ":"+string:port) 
 307    http path := path 
 308    http datetime := options option "datetime" DateTime 
 309    http options := options 
 310    http opened_on := datetime 
 311    http:log bind http_trace 
 312    var Str msg := "" 
 313    if (flags .and. in_out)=in 
 314      var CBool post := options option "form" 
 315      var Str option := options option "option" Str 
 316      tcp writeline (shunt post "POST" "GET")+" /"+path+(shunt option<>"" "?"+option "")+" HTTP/1.0" http:log 
 317      write_http_options server options tcp http:log 
 318      if post 
 319        tcp writechars (options option "form" Str) 
 320      var Str answer := tcp readline http:log 
 321      if not (answer parse "HTTP/" (var Float protocol_level) _ (var Int retcode) _ any) 
 322        if not (options option "http_streaming"or not (answer parse any _ (var Int retcode) _ any) 
 323          return (failure "Unexpected answer "+string:answer+" from "+string:server) 
 324      msg := "http_return_code "+string:retcode 
 325      while { var Str := tcp readline http:log ; l<>"" } 
 326        msg += " http_answer_option "+string:l 
 327        if (parse "Content-Type" ":" any:(var Str value)) 
 328          http mime := value 
 329      if retcode>=300 
 330        return failure:msg 
 331    eif (flags .and. in_out)=out 
 332      var Intn size := options option "file_size" Intn 
 333      if size<>undefined 
 334        if debug 
 335          console "upload on the fly "+options eol 
 336        http direct := true 
 337        http remain := size 
 338        status := http write_header size tcp http:log 
 339        if status=failure 
 340          return 
 341      else 
 342        if debug 
 343          console "store then upload" eol 
 344        http filename := file_temporary 
 345        http temp :> new Stream 
 346        http:temp open http:filename out+(flags .and. safe) 
 347    else 
 348      return failure 
 349    stream stream_driver :> http 
 350    status := success ; status message := msg 
 351       
 352  method fs configure name options command -> status 
 353    arg_rw HttpFileSystem fs ; arg Str name options command ; arg ExtendedStatus status 
 354    if command="delete" 
 355      if (name eparse "//" any:(var Str server) "/" any:(var Str path)) 
 356        void 
 357      else 
 358        return failure 
 359      var Int port 
 360      if (server eparse any:(var Str server1) ":" port) 
 361        server := server1 
 362      else 
 363        port := 80 
 364      var Str channel := options option "channel" Str 
 365      if channel="" 
 366        channel := "tcp://"+server+"/client/"+string:port 
 367      (var Stream tcp) open channel in+out+safe+cr+lf 
 368      if tcp=failure 
 369        http_trace trace "Failed to connect to " channel 
 370        return failure 
 371      (var TraceSession log) bind http_trace 
 372      tcp writeline "DELETE /"+path+" HTTP/1.0" log 
 373      write_http_options server options tcp log 
 374      var Str answer := tcp readline log 
 375      status := shunt (answer parse "HTTP/" (var Float protocol_level) _ (var Int retcode) _ any) and retcode<300 success (failure "HTTP server rejected delete command "+string:answer) 
 376    eif false # (command parse word:"datetime" (var DateTime dt)) 
 377      console "set date and time to " dt eol 
 378      if (name eparse "//" any:(var Str server) "/" any:(var Str path)) 
 379        void 
 380      else 
 381        return failure 
 382      var Int port 
 383      if (server eparse any:(var Str server1) ":" port) 
 384        server := server1 
 385      else 
 386        port := 80 
 387      var Str channel := options option "channel" Str 
 388      if channel="" 
 389        channel := "tcp://"+server+"/client/"+string:port 
 390      (var Stream tcp) open channel in+out+safe+cr+lf 
 391      if tcp=failure 
 392        http_trace trace "Failed to connect to " channel 
 393        return failure 
 394   
 395      (var TraceSession log) bind http_trace 
 396      tcp writeline "PROPFIND /"+path+" HTTP/1.0" log 
 397      var Str form := "" 
 398      form += "<?xml version=[dq]1.0[dq] encoding=[dq]utf-8[dq] ?>[lf]" 
 399      form += "<propfind xmlns=[dq]DAV:[dq]>[lf]" 
 400      form += "  <allprop/>[lf]" 
 401      form += "</propfind>[lf]" 
 402      write_http_options server "form "+string:form+" "+options tcp log 
 403      tcp writechars form 
 404      console form 
 405      var Str answer := tcp readline log 
 406      console "answer is " answer eol 
 407      status := shunt (answer parse "HTTP/" (var Float protocol_level) _ (var Int retcode) _ any) and retcode<300 success (failure "HTTP server rejected delete command "+string:answer) 
 408      while not tcp:atend 
 409        console tcp:readline eol 
 410   
 411      (var TraceSession log) bind http_trace 
 412      console "PROPPATCH /"+path+" HTTP/1.0" eol 
 413      tcp writeline "PROPPATCH /"+path+" HTTP/1.0" log 
 414      var Str form := "" 
 415      form += "<?xml version=[dq]1.0[dq] encoding=[dq]utf-8[dq] ?>[lf]" 
 416      form += "<D:propertyupdate xmlns:D=[dq]DAV:[dq]>[lf]" 
 417      form += "<D:set>[lf]" 
 418      form += "<D:prop>[lf]" 
 419      form += "<D:getlastmodified>"+rfc1123_date:dt+"</D:getlastmodified>[lf]" 
 420      form += "</D:prop>[lf]" 
 421      form += "</D:set>[lf]" 
 422      form += "</D:propertyupdate>[lf]" 
 423      write_http_options server "form "+string:form+" "+options tcp log 
 424      tcp writechars form 
 425      console form 
 426      var Str answer := tcp readline log 
 427      console "answer is " answer eol 
 428      status := shunt (answer parse "HTTP/" (var Float protocol_level) _ (var Int retcode) _ any) and retcode<300 success (failure "HTTP server rejected delete command "+string:answer) 
 429      while not tcp:atend 
 430        console tcp:readline eol 
 431    else 
 432      status := failure 
 433   
 434  gvar HttpFileSystem http_file_system 
 435  pliant_multi_file_system mount "http:" "" http_file_system 
 436