← Back to branch summary

~ubuntu-branches/ubuntu/trusty/ocamlnet/trusty

« back to all changes in this revision

Viewing changes to src/netclient/http_fs.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu
  • Date: 2011-09-02 14:12:33 UTC
  • mfrom: (18.2.3 sid)
  • Revision ID: james.westby@ubuntu.com-20110902141233-zbj0ygxb92u6gy4z
Tags: 3.4-1
http://bugs.debian.org/637147
* New upstream release
  - add a new NetcgiRequire directive to ease dependency management
    (Closes: #637147)
  - remove patches that were applied upstream:
    + Added-missing-shebang-lines-in-example-shell-scripts
    + Try-also-ocamlc-for-POSIX-threads

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/netclient/http_fs.ml
 
1
(* $Id: http_fs.ml 1661 2011-08-28 22:45:55Z gerd $ *)
 
2
 
 
3
(* TODO:
 
4
   - factor streaming get/put out
 
5
 *)
 
6
 
 
7
 
 
8
open Printf
 
9
module StrSet = Set.Make(String)
 
10
 
 
11
 
 
12
type read_flag =
 
13
    [ Netfs.read_flag | `Header of (string*string)list ]
 
14
 
 
15
type read_file_flag =
 
16
    [ Netfs.read_file_flag | `Header of (string*string)list ]
 
17
 
 
18
type write_flag =
 
19
    [ Netfs.write_flag | `Header of (string*string)list ]
 
20
 
 
21
type write_file_flag =
 
22
    [ Netfs.write_file_flag | `Header of (string*string)list ]
 
23
 
 
24
type any_wflag = [ write_flag | write_file_flag ]
 
25
 
 
26
class type http_stream_fs =
 
27
object
 
28
  method read : read_flag list -> string -> Netchannels.in_obj_channel
 
29
  method read_file : read_file_flag list -> string -> Netfs.local_file
 
30
  method write : write_flag list -> string -> Netchannels.out_obj_channel
 
31
  method write_file : write_file_flag list -> string -> Netfs.local_file -> unit
 
32
  method last_response_header : Nethttp.http_header
 
33
  method pipeline : Http_client.pipeline
 
34
  method translate : string -> string
 
35
 
 
36
  method path_encoding : Netconversion.encoding option
 
37
  method path_exclusions : (int * int) list
 
38
  method nominal_dot_dot : bool
 
39
  method size : Netfs.size_flag list -> string -> int64
 
40
  method test : Netfs.test_flag list -> string -> Netfs.test_type -> bool
 
41
  method test_list : Netfs.test_flag list -> string -> Netfs.test_type list -> bool list
 
42
  method remove : Netfs.remove_flag list -> string -> unit
 
43
  method rename : Netfs.rename_flag list -> string -> string -> unit
 
44
  method symlink : Netfs.symlink_flag list -> string -> string -> unit
 
45
  method readdir : Netfs.readdir_flag list -> string -> string list
 
46
  method readlink : Netfs.readlink_flag list -> string -> string
 
47
  method mkdir : Netfs.mkdir_flag list -> string -> unit
 
48
  method rmdir : Netfs.rmdir_flag list -> string -> unit
 
49
  method copy : Netfs.copy_flag list -> string -> string -> unit
 
50
  method cancel : unit -> unit
 
51
end
 
52
 
 
53
(* ensure this is a subtype of Netfs.stream_fs *)
 
54
let _f (x : http_stream_fs) =
 
55
  ignore(x :> Netfs.stream_fs)
 
56
 
 
57
 
 
58
let http_body ~open_value_rd ~open_value_wr =
 
59
object(self)
 
60
  method open_value_rd = open_value_rd
 
61
  method open_value_wr = open_value_wr
 
62
  method value = failwith "value: not supported here"
 
63
  method store = failwith "store: not supported here"
 
64
  method finalize() = ()
 
65
  method ro = false
 
66
  method set_value _ = failwith "set_value: not supported here"
 
67
end
 
68
 
 
69
 
 
70
let buffer_body ?(add_sub_string = Netpagebuffer.add_sub_string)
 
71
                buf eof ondata onempty drop : Netmime.mime_body =
 
72
  (* ondata: is called whenever new data becomes available. The arg is
 
73
     the number of buffered bytes
 
74
     onempty: is called when the input side runs out of data
 
75
     drop: this number of bytes are dropped
 
76
   *)
 
77
  let drop = ref drop in
 
78
  http_body
 
79
    ~open_value_rd:(
 
80
      fun () ->
 
81
        let (inch : Netchannels.rec_in_channel) =
 
82
          ( object
 
83
              method input s pos len =
 
84
                let buf_len = Netpagebuffer.length buf in
 
85
                if buf_len = 0 then (
 
86
                  if !eof then raise End_of_file else onempty()
 
87
                );
 
88
                let buf_len = Netpagebuffer.length buf in
 
89
                let n = min len buf_len in
 
90
                Netpagebuffer.blit_to_string buf 0 s pos n;
 
91
                Netpagebuffer.delete_hd buf n;
 
92
                n
 
93
              method close_in() =
 
94
                ()
 
95
            end
 
96
          ) in
 
97
        Netchannels.lift_in ~buffered:false (`Rec inch)
 
98
    )
 
99
    ~open_value_wr:(
 
100
      fun () ->
 
101
        let (out : Netchannels.rec_out_channel) =
 
102
          ( object
 
103
              method output s pos len =
 
104
                let d = Int64.to_int (min !drop (Int64.of_int len)) in
 
105
                drop := Int64.sub !drop (Int64.of_int d);
 
106
                let len' = len - d in
 
107
                if len' > 0 then (
 
108
                  add_sub_string buf s (pos + d) len';
 
109
                  ondata(Netpagebuffer.length buf)
 
110
                );
 
111
                len
 
112
              method flush() = ()
 
113
              method close_out() = 
 
114
                eof := true;
 
115
                ondata(Netpagebuffer.length buf)
 
116
            end
 
117
          ) in
 
118
        Netchannels.lift_out ~buffered:false (`Rec out)
 
119
    )
 
120
  
 
121
 
 
122
let discarding_body() : Netmime.mime_body =
 
123
  http_body  
 
124
    ~open_value_rd:(
 
125
      fun () ->
 
126
        let (inch : Netchannels.rec_in_channel) =
 
127
          ( object
 
128
              method input s pos len =
 
129
                raise End_of_file
 
130
              method close_in() =
 
131
                ()
 
132
            end
 
133
          ) in
 
134
        Netchannels.lift_in ~buffered:false (`Rec inch)
 
135
    )
 
136
    ~open_value_wr:(
 
137
      fun () ->
 
138
        let (out : Netchannels.rec_out_channel) =
 
139
          ( object
 
140
              method output s pos len =
 
141
                len
 
142
              method flush() = ()
 
143
              method close_out() = ()
 
144
            end
 
145
          ) in
 
146
        Netchannels.lift_out ~buffered:false (`Rec out)
 
147
    )
 
148
 
 
149
 
 
150
let drop_out_channel ch drop =
 
151
  (* drops the first n bytes written to it, and the remaining bytes are
 
152
     sent to ch
 
153
   *)
 
154
  let drop = ref drop in
 
155
  let out =
 
156
    ( object(self)
 
157
        method output s pos len =
 
158
          let d = Int64.to_int (min !drop (Int64.of_int len)) in
 
159
          drop := Int64.sub !drop (Int64.of_int d);
 
160
          let len' = len - d in
 
161
          ch # really_output s (pos+d) len';
 
162
          len'
 
163
        method flush() = ch # flush()
 
164
        method close_out() = ch # close_out()
 
165
      end
 
166
    ) in
 
167
  Netchannels.lift_out ~buffered:false (`Rec out)
 
168
 
 
169
 
 
170
let rec find_file_members =
 
171
  function
 
172
    | Nethtml.Element(e,atts,subl) ->
 
173
        let m =
 
174
          if String.lowercase e = "a" then (
 
175
            try
 
176
              let href = List.assoc "href" atts in
 
177
              if href="" || href.[0] = '/' then raise Not_found;
 
178
              try
 
179
                let i = String.index href '/' in
 
180
                if i+1=String.length href then
 
181
                  [String.sub href 0 (String.length href-1)]
 
182
                else
 
183
                  []
 
184
              with Not_found -> [href]
 
185
            with Not_found -> []
 
186
          )
 
187
          else [] in
 
188
        m @ find_file_members_in_list subl
 
189
    | Nethtml.Data _ -> []
 
190
and find_file_members_in_list l =
 
191
  List.flatten
 
192
    (List.map find_file_members l)
 
193
 
 
194
 
 
195
let unique_str_list l =
 
196
  let set =
 
197
    List.fold_left (fun acc s -> StrSet.add s acc) StrSet.empty l in
 
198
  StrSet.elements set
 
199
 
 
200
 
 
201
exception Interrupt
 
202
 
 
203
 
 
204
let is_error_response ?(precondfailed = Unix.EPERM) path call =
 
205
  match call#status with
 
206
    | `Unserved -> None
 
207
    | `Successful -> None
 
208
    | `Http_protocol_error e -> Some e
 
209
    | `Redirection | `Client_error | `Server_error ->
 
210
        ( match call # response_status with
 
211
            | `Not_found ->
 
212
                Some(Unix.Unix_error(Unix.ENOENT, "Http_fs", path))
 
213
            | `Forbidden | `Unauthorized ->
 
214
                Some(Unix.Unix_error(Unix.EACCES, "Http_fs", path))
 
215
            | `Precondition_failed ->
 
216
                Some(Unix.Unix_error(precondfailed, "Http_fs", path))
 
217
            | _ ->
 
218
                Some(Unix.Unix_error(Unix.EPERM, "Http_fs", path))
 
219
        )
 
220
 
 
221
 
 
222
let find_flag f flags =
 
223
  let rec loop l =
 
224
    match l with
 
225
      | flag :: l' ->
 
226
          ( match f flag with
 
227
              | None -> loop l'
 
228
              | Some x -> x
 
229
          )
 
230
      | [] ->
 
231
          raise Not_found in
 
232
  loop flags
 
233
 
 
234
 
 
235
class http_fs
 
236
        ?(config_pipeline = fun p -> ())
 
237
        ?(streaming = false)
 
238
        ?tmp_directory
 
239
        ?tmp_prefix
 
240
        ?(path_encoding = `Enc_utf8)
 
241
        ?(enable_read_for_directories=false)
 
242
        ?(enable_ftp=false)
 
243
        (* ?(is_error_response = is_error_response) *)
 
244
        base_url : http_stream_fs =
 
245
  let p = new Http_client.pipeline in
 
246
  let () =
 
247
    if enable_ftp then (
 
248
      let ftp_syn = Hashtbl.find Neturl.common_url_syntax "ftp" in
 
249
      let opts = p # get_options in
 
250
      let opts' =
 
251
        { opts with
 
252
            Http_client.schemes = opts.Http_client.schemes @
 
253
            [ "ftp", ftp_syn, Some 21, Http_client.proxy_only_cb_id ]
 
254
        } in
 
255
      p # set_options opts'
 
256
    ) in
 
257
  let () = config_pipeline p in
 
258
  let base_url_ends_with_slash =
 
259
    base_url <> "" && base_url.[String.length base_url-1] = '/' in
 
260
  let einval path detail =
 
261
    raise(Unix.Unix_error(Unix.EINVAL, detail, path)) in
 
262
  let translate path =
 
263
    if path = "" then
 
264
      einval path "Http_fs: path is empty";
 
265
    if path.[0] <> '/' then
 
266
      einval path "Http_fs: path is not absolute";
 
267
    if String.contains path '\000' then
 
268
      einval path "Http_fs: path contains NUL byte";
 
269
    ( try
 
270
        Netconversion.verify path_encoding path
 
271
      with
 
272
        | Netconversion.Malformed_code_at _ ->
 
273
            einval path "Http_fs: path is not properly encoded"
 
274
    );
 
275
    let npath = Neturl.norm_path(Neturl.split_path path) in
 
276
    let npath_s = Neturl.join_path npath in
 
277
    ( match npath with
 
278
        | "" :: ".." :: _ -> (* CHECK: maybe ENOENT? *)
 
279
            einval path "Http_fs: path starts with /.."
 
280
        | _ -> ()
 
281
    );
 
282
    if base_url_ends_with_slash then
 
283
      base_url ^ String.sub npath_s 1 (String.length npath_s - 1)
 
284
    else
 
285
      base_url ^ npath_s
 
286
  in
 
287
  let handle_error ?precondfailed path call =
 
288
    match call#status with
 
289
      | `Unserved -> assert false
 
290
      | `Successful -> assert false
 
291
      | _ ->
 
292
          ( match is_error_response ?precondfailed path call with
 
293
              | None -> 
 
294
                  failwith "Http_fs: No response received but \
 
295
                            is_error_response does not indicate an error"
 
296
              | Some e ->
 
297
                  raise e
 
298
          )
 
299
  in
 
300
  let is_dir_url url =
 
301
    url <> "" && url.[String.length url - 1] = '/' in
 
302
  let check_dir url path =
 
303
    if is_dir_url url then
 
304
      raise(Unix.Unix_error(Unix.EISDIR, "Http_fs", path)) in
 
305
  let run () =
 
306
    try p#run()
 
307
    with Interrupt -> () in
 
308
  let last_response_header = ref None in
 
309
 
 
310
  let cancel_flag = ref (ref false) in
 
311
  
 
312
 
 
313
object(self)
 
314
  method path_encoding = Some path_encoding
 
315
  method path_exclusions = [0,0; 47,47]
 
316
  method nominal_dot_dot = true
 
317
  method pipeline = p
 
318
  method translate = translate
 
319
 
 
320
  method last_response_header =
 
321
    match !last_response_header with
 
322
      | None ->
 
323
          raise Not_found
 
324
      | Some hdr ->
 
325
          hdr
 
326
 
 
327
  method read flags path =
 
328
    let url = translate path in
 
329
    let call = new Http_client.get url in
 
330
    let g = Unixqueue.new_group p#event_system in
 
331
    let req_hdr = call # request_header `Base in
 
332
    let skip = 
 
333
      try find_flag (function `Skip p -> Some p | _ -> None) flags
 
334
      with Not_found -> 0L in
 
335
    if skip > 0L then
 
336
      Nethttp.Header.set_range req_hdr (`Bytes[Some skip, None]);
 
337
    call # set_accept_encoding();
 
338
    let header =
 
339
      try find_flag (function `Header h -> Some h | _ -> None) flags
 
340
      with Not_found -> [] in
 
341
    List.iter (fun (n,v) -> req_hdr # update_field n v) header;
 
342
    last_response_header := None;
 
343
 
 
344
    if streaming || List.mem `Streaming flags then (
 
345
      let onempty() = () in
 
346
      let page_size = Netsys_mem.pagesize in
 
347
      let buf = Netpagebuffer.create page_size in
 
348
      let eof = ref false in
 
349
      let running = ref true in  (* prevents that Interrupt escapes *)
 
350
      let ondata n =
 
351
        if not !eof then
 
352
          Unixqueue.once p#event_system g 0.0
 
353
            (fun () -> if !running then raise Interrupt) in
 
354
      let cur_ch = ref None in
 
355
      let call_done = ref false in
 
356
      call # set_response_body_storage
 
357
        (`Body (fun () -> 
 
358
                  (* Check whether this is the last body *)
 
359
                  last_response_header := Some(call#response_header);
 
360
                  match is_error_response path call with
 
361
                    | None ->
 
362
                        if !cur_ch <> None then
 
363
                          failwith "Http_fs: unexpected reconnect";
 
364
                        let code = call#response_status_code in
 
365
                        let drop =
 
366
                          (* Maybe Range headers are not supported: *)
 
367
                          if code = 200 && skip > 0L then skip else 0L in
 
368
                        let body = buffer_body buf eof ondata onempty drop in
 
369
                        cur_ch := Some (body # open_value_rd());
 
370
                        body
 
371
                    | Some _ ->
 
372
                        discarding_body()
 
373
               ));
 
374
      (* We cannot reconnect in streaming mode :-( *)
 
375
      call # set_reconnect_mode Http_client.Request_fails;
 
376
      p # add_with_callback call (fun _ -> call_done := true);
 
377
      (* Wait until data is available, or the whole call is done (in case
 
378
         of error)
 
379
       *)
 
380
      try
 
381
        run();
 
382
        match !cur_ch with
 
383
          | None ->
 
384
              (* Error *)
 
385
              handle_error path call  (* raise exception *)
 
386
          | Some c_ch ->
 
387
              (* Success *)
 
388
              if not enable_read_for_directories then
 
389
                check_dir (call # effective_request_uri) path;
 
390
              let (ch : Netchannels.rec_in_channel) =
 
391
                ( object
 
392
                    method input s pos len =
 
393
                      while (not !call_done && not !eof && 
 
394
                               Netpagebuffer.length buf < 16 * page_size)
 
395
                      do
 
396
                        run()
 
397
                      done;
 
398
                      if !call_done then run();   (* ensure proper shutdown *)
 
399
                      ( try
 
400
                          c_ch # input s pos len
 
401
                        with
 
402
                          | End_of_file ->
 
403
                              (* check for pending error *)
 
404
                              ( match is_error_response path call with
 
405
                                  | None -> raise End_of_file
 
406
                                  | Some e -> handle_error path call
 
407
                              )
 
408
                      )
 
409
                    method close_in() =
 
410
                      try
 
411
                        p # reset();
 
412
                        while not !call_done do run() done;
 
413
                        running := false;
 
414
                        (* We ignore any pending error here *)
 
415
                      with
 
416
                        | err -> running := false; raise err
 
417
                  end
 
418
                ) in
 
419
              Netchannels.lift_in ~buffered:true (`Rec ch)
 
420
      with
 
421
        | err -> running := false; raise err
 
422
    )
 
423
    else (
 
424
      let cur_tmp = ref None in 
 
425
      call # set_response_body_storage
 
426
        (`Body (fun () -> 
 
427
                  last_response_header := Some(call#response_header);
 
428
                  (* Check whether this is the last body *)
 
429
                  match is_error_response path call with
 
430
                    | None ->
 
431
                        let (tmp_name, inch, outch) =
 
432
                          Netchannels.make_temporary_file 
 
433
                            ?tmp_directory ?tmp_prefix () in
 
434
                        cur_tmp := Some (tmp_name, inch);
 
435
                        let code = call#response_status_code in
 
436
                        let drop =
 
437
                          (* Maybe Range headers are not supported: *)
 
438
                          if code = 200 && skip > 0L then skip else 0L in
 
439
                        http_body
 
440
                          ~open_value_rd:(fun () -> 
 
441
                                            new Netchannels.input_channel inch)
 
442
                          ~open_value_wr: (
 
443
                            fun () ->
 
444
                              drop_out_channel
 
445
                                (new Netchannels.output_channel outch)
 
446
                                drop)
 
447
                    | Some _ ->
 
448
                        discarding_body()
 
449
               ));
 
450
      p # add call;
 
451
      run();
 
452
      match !cur_tmp with
 
453
        | None ->
 
454
            (* Error *)
 
455
            handle_error path call  (* raise exception *)
 
456
        | Some (tmp_name,c_ch) ->
 
457
            (* Success *)
 
458
            Unix.unlink tmp_name;  (* CHECK Win32 *)
 
459
            if not enable_read_for_directories then
 
460
              check_dir (call # effective_request_uri) path;
 
461
            call # response_body # open_value_rd()
 
462
    )
 
463
 
 
464
  method read_file flags path =
 
465
    let url = translate path in
 
466
    let call = new Http_client.get url in
 
467
    let req_hdr = call # request_header `Base in
 
468
    call # set_accept_encoding();
 
469
    let header =
 
470
      try find_flag (function `Header h -> Some h | _ -> None) flags
 
471
      with Not_found -> [] in
 
472
    List.iter (fun (n,v) -> req_hdr # update_field n v) header;
 
473
    last_response_header := None;
 
474
 
 
475
    let cur_tmp = ref None in 
 
476
    call # set_response_body_storage
 
477
      (`Body (fun () -> 
 
478
                last_response_header := Some(call#response_header);
 
479
                (* Check whether this is the last body *)
 
480
                match is_error_response path call with
 
481
                  | None ->
 
482
                      let (tmp_name, inch, outch) =
 
483
                        Netchannels.make_temporary_file 
 
484
                          ?tmp_directory ?tmp_prefix () in
 
485
                      close_in inch;
 
486
                      cur_tmp := Some tmp_name;
 
487
                      http_body
 
488
                        ~open_value_rd:(fun () -> 
 
489
                                          new Netchannels.input_channel inch)
 
490
                        ~open_value_wr: (fun () ->
 
491
                                           new Netchannels.output_channel outch)
 
492
                  | Some _ ->
 
493
                      discarding_body()
 
494
             ));
 
495
    p # add call;
 
496
    run();
 
497
    match !cur_tmp with
 
498
      | None ->
 
499
          (* Error *)
 
500
          handle_error path call  (* raise exception *)
 
501
      | Some tmp_name ->
 
502
          (* Success *)
 
503
          let close() =
 
504
            try Unix.unlink tmp_name with _ -> () in
 
505
          if not enable_read_for_directories then
 
506
            check_dir (call # effective_request_uri) path;
 
507
          ( object
 
508
              method filename = tmp_name
 
509
              method close = close
 
510
            end
 
511
          )
 
512
 
 
513
  method write flags path =
 
514
    self # write_impl (flags :> any_wflag list) path None
 
515
 
 
516
  method write_file flags path local =
 
517
    ignore(self # write_impl (flags :> any_wflag list) path (Some local))
 
518
 
 
519
  method private write_impl flags path local_opt =
 
520
    let this_cancel_flag = !cancel_flag in
 
521
    let url = translate path in
 
522
    let call = new Http_client.put_call in
 
523
    call # set_request_uri url;
 
524
    let g = Unixqueue.new_group p#event_system in
 
525
    let req_hdr = call # request_header `Base in
 
526
    req_hdr # update_field "Content-Type" "application/octet-stream";
 
527
    req_hdr # update_field "Expect" "100-continue";
 
528
    let header =
 
529
      try find_flag (function `Header h -> Some h | _ -> None) flags
 
530
      with Not_found -> [] in
 
531
    List.iter (fun (n,v) -> req_hdr # update_field n v) header;
 
532
    last_response_header := None;
 
533
 
 
534
    let create_flag = List.mem `Create flags in
 
535
    let trunc_flag = List.mem `Truncate flags in
 
536
    let excl_flag = List.mem `Exclusive flags in
 
537
 
 
538
    if not create_flag && not trunc_flag then
 
539
      einval path "Http_fs.write: you need to request either file creation \
 
540
                   or file truncation";
 
541
 
 
542
    let precondfailed = ref Unix.EPERM in
 
543
 
 
544
    if create_flag && excl_flag then (
 
545
      req_hdr # update_field "If-None-Match" "*";
 
546
      (* = do PUT only if the file does not exist *)
 
547
      precondfailed := Unix.EEXIST;
 
548
    );
 
549
    if create_flag && not excl_flag && not trunc_flag then (
 
550
      req_hdr # update_field "If-None-Match" "*";
 
551
      (* = do PUT only if the file does not exist *)
 
552
      precondfailed := Unix.EPERM;
 
553
    );
 
554
    if not create_flag then (
 
555
      req_hdr # update_field "If-Match" "*";
 
556
      (* = do PUT only if the file exists *)
 
557
      precondfailed := Unix.ENOENT;
 
558
    );
 
559
 
 
560
    let precondfailed = !precondfailed in
 
561
            
 
562
    last_response_header := None;
 
563
    if (streaming || List.mem `Streaming flags) && local_opt = None then (
 
564
      (* We cannot reconnect in streaming mode :-( *)
 
565
      call # set_reconnect_mode Http_client.Request_fails;
 
566
      (* We have to use chunked transfer encoding: *)
 
567
      req_hdr # update_field "Transfer-Encoding" "chunked";
 
568
 
 
569
      let page_size = Netsys_mem.pagesize in
 
570
      let buf = Netpagebuffer.create page_size in
 
571
      let eof = ref false in
 
572
      let added = ref false in
 
573
      let running = ref true in  (* prevents that Interrupt escapes *)
 
574
 
 
575
      let ondata n = 
 
576
        if n>=16*page_size || !eof then (
 
577
          if not !added then (
 
578
            p # add call;
 
579
            added := true
 
580
          );
 
581
          if !eof then (
 
582
            (* last chunk: *)
 
583
            Netpagebuffer.add_string buf "0\r\n\r\n"
 
584
          );
 
585
          run();
 
586
          if !eof then (
 
587
            running := false;
 
588
            (* check for errors *)
 
589
            last_response_header := Some(call#response_header);
 
590
            match is_error_response ~precondfailed path call with
 
591
              | None -> ()
 
592
              | Some e -> handle_error ~precondfailed path call
 
593
          )
 
594
        ) in
 
595
      let onempty () =
 
596
        Unixqueue.once p#event_system g 0.0
 
597
          (fun () -> if !running then raise Interrupt) in
 
598
      let add_sub_string buf s pos len =
 
599
        (* Create a chunk: *)
 
600
        Netpagebuffer.add_string buf (sprintf "%x\r\n" len);
 
601
        Netpagebuffer.add_sub_string buf s pos len;
 
602
        Netpagebuffer.add_string buf "\r\n";
 
603
      in
 
604
      let body = buffer_body ~add_sub_string buf eof ondata onempty 0L in
 
605
      call # set_request_body body;
 
606
 
 
607
      body # open_value_wr()
 
608
    )
 
609
    else (
 
610
      let (fname, mk_return, close) =
 
611
        match local_opt with
 
612
          | None ->
 
613
              let (n,inch,outch) =
 
614
                Netchannels.make_temporary_file 
 
615
                  ?tmp_directory ?tmp_prefix () in
 
616
              close_in inch;
 
617
              let mkr onclose =
 
618
                new Netchannels.output_channel ~onclose outch in
 
619
              let close() =
 
620
                (try Unix.unlink n with _ -> ()) in
 
621
              (n, mkr, close)
 
622
          | Some local ->
 
623
              let mkr onclose =
 
624
                onclose();
 
625
                new Netchannels.output_null() in
 
626
              (local#filename, mkr, local#close) in
 
627
 
 
628
      let onclose() =
 
629
        if !this_cancel_flag then
 
630
          close()
 
631
        else (
 
632
          let st = Unix.LargeFile.stat fname in
 
633
          req_hdr # update_field
 
634
            "Content-length" (Int64.to_string st.Unix.LargeFile.st_size);
 
635
          call # set_request_body (new Netmime.file_mime_body fname);
 
636
          ( try
 
637
              p # add call;
 
638
              run();
 
639
              close()
 
640
            with e -> close(); raise e
 
641
          );
 
642
          last_response_header := Some(call#response_header);
 
643
          match is_error_response ~precondfailed path call with
 
644
            | None ->
 
645
                ()
 
646
            | Some e ->
 
647
                raise e
 
648
        )
 
649
      in
 
650
      
 
651
      mk_return onclose
 
652
    )
 
653
 
 
654
  method cancel() =
 
655
    (* This cancellation affects all [write]s that were started until
 
656
       now...
 
657
     *)
 
658
    let this_cancel_flag = !cancel_flag in
 
659
    this_cancel_flag := true;
 
660
    (* All new [write]s are not cancelled, of course: *)
 
661
    cancel_flag := (ref false)
 
662
 
 
663
  method size _ path =
 
664
    last_response_header := None;
 
665
    let url = translate path in
 
666
    let call = new Http_client.head url in
 
667
    p#add call;
 
668
    p#run();
 
669
    last_response_header := Some(call#response_header);
 
670
    match is_error_response path call with
 
671
      | None ->
 
672
          ( try
 
673
              Int64.of_string(call # response_header # field "Content-length")
 
674
            with
 
675
              | Not_found ->
 
676
                  raise(Unix.Unix_error(Unix.ESPIPE,"Http_fs",path))
 
677
              | _ ->
 
678
                  raise(Http_client.Bad_message
 
679
                          ("Field Content-length: Parse error"))
 
680
          )
 
681
      | Some _ ->
 
682
          handle_error path call
 
683
 
 
684
  method test flags path t =
 
685
    List.hd(self # test_list flags path [t])
 
686
 
 
687
  method test_list flags path tl =
 
688
    last_response_header := None;
 
689
    let url = translate path in
 
690
    let call = new Http_client.head url in
 
691
    p#add call;
 
692
    p#run();
 
693
    last_response_header := Some(call#response_header);
 
694
    match is_error_response path call with
 
695
      | None ->
 
696
          let is_dir =
 
697
            is_dir_url(call # effective_request_uri) in
 
698
          let not_empty =
 
699
            try
 
700
              Int64.of_string
 
701
                (call # response_header # field "Content-length") > 0L
 
702
            with
 
703
              | _ -> false in
 
704
          List.map
 
705
            (function
 
706
               | `N -> true
 
707
               | `E -> true
 
708
               | `F -> not is_dir
 
709
               | `D -> is_dir
 
710
               | `H -> false
 
711
               | `R -> true
 
712
               | `W -> false
 
713
               | `X -> is_dir
 
714
               | `S -> not_empty
 
715
            )
 
716
            tl
 
717
      | Some _ ->
 
718
          (* We only raise protocol exceptions *)
 
719
          match call#status with
 
720
            | `Unserved -> assert false
 
721
            | `Http_protocol_error e -> raise e
 
722
            | `Successful -> assert false
 
723
            | `Redirection | `Client_error | `Server_error ->
 
724
                List.map (fun _ -> false) tl
 
725
 
 
726
  method readdir _ path =
 
727
    let fail() =
 
728
      (* We generally return ENOTDIR - meaning we cannot access this as
 
729
         directory.
 
730
       *)
 
731
      raise(Unix.Unix_error(Unix.ENOTDIR,"Http_fs.readdir",path)) in
 
732
    last_response_header := None;
 
733
    let path1 =
 
734
      if path <> "" && path.[String.length path - 1] <> '/' then
 
735
        path ^ "/"
 
736
      else
 
737
        path in
 
738
    let url = translate path1 in
 
739
    let call = new Http_client.get url in
 
740
    p#add call;
 
741
    p#run();
 
742
    last_response_header := Some(call#response_header);
 
743
    match is_error_response path call with
 
744
      | None ->
 
745
          (* The is_dir_url test only works if the server redirects to a
 
746
             URL ending with a slash. Some servers don't do this.
 
747
           *)
 
748
          (* if not (is_dir_url(call # effective_request_uri)) then fail(); *)
 
749
          (* Get the MIME type and the charset of the result: *)
 
750
          let (cont_type, charset) =
 
751
            try
 
752
              let (cont_type, params) = call#response_header#content_type() in
 
753
              let charset = 
 
754
                try Mimestring.param_value(List.assoc "charset" params)
 
755
                with Not_found -> "US-ASCII" in
 
756
              (* FIXME: We could also look into the doc *)
 
757
              (cont_type, charset)
 
758
            with _ -> fail() in
 
759
          (* we only support text/html: *)
 
760
          if String.lowercase cont_type <> "text/html" then fail();
 
761
          (* check if we know the encoding: *)
 
762
          let enc =
 
763
            try Netconversion.encoding_of_string charset
 
764
            with _ -> fail() in
 
765
          (* convert to UTF-8 *)
 
766
          let text0 = call#response_body#value in
 
767
          let text =
 
768
            try
 
769
              Netconversion.convert ~in_enc:enc ~out_enc:`Enc_utf8 text0
 
770
            with
 
771
              | _ -> fail() in
 
772
          (* Now parse this *)
 
773
          let html = Nethtml.parse (new Netchannels.input_string text) in
 
774
          let names = find_file_members_in_list html in
 
775
          (* Convert the names to our path encoding. Omit names with
 
776
             conversion errors.
 
777
           *)
 
778
          let base_syntax = Neturl.ip_url_syntax in
 
779
          let names1 =
 
780
            List.flatten
 
781
              (List.map
 
782
                 (fun name -> 
 
783
                    try
 
784
                      let u = 
 
785
                        Neturl.parse_url ~base_syntax ~accept_8bits:true 
 
786
                          (Neturl.fixup_url_string name) in
 
787
                      let q1 = Neturl.url_path u in
 
788
                      (* Some URLs contain "%2f" in the path. We don't like
 
789
                         this
 
790
                       *)
 
791
                      if List.exists (fun s -> String.contains s '/') q1 then
 
792
                        raise Not_found;
 
793
                      let q2 =
 
794
                        if q1 <> [] && q1 <> [""] then
 
795
                          let r1 = List.rev q1 in
 
796
                          if List.hd r1 = "" then 
 
797
                            List.rev(List.tl r1)
 
798
                          else
 
799
                            q1
 
800
                        else
 
801
                          q1 in
 
802
                      if q2 <> [] && not(List.mem "" q2) then (
 
803
                        let qj = Neturl.join_path q2 in
 
804
                        Netconversion.verify path_encoding qj;
 
805
                        [ qj ]
 
806
                      )
 
807
                      else []
 
808
                    with _ -> []
 
809
                 )
 
810
                 names
 
811
              ) in
 
812
          let names2 = "." :: ".." :: names1 in
 
813
          unique_str_list names2
 
814
      | Some(Unix.Unix_error(Unix.ENOENT,_,_)) ->
 
815
          fail()   (* prefer ENOTDIR in this case *)
 
816
      | Some _ ->
 
817
          handle_error path call
 
818
 
 
819
  method remove flags path =
 
820
    last_response_header := None;
 
821
    if List.mem `Recursive flags then
 
822
      raise(Unix.Unix_error(Unix.EINVAL,
 
823
                            "Http_fs.remove: recursion not supported",
 
824
                            path));
 
825
    let url = translate path in
 
826
    let call = new Http_client.get url in
 
827
    p#add call;
 
828
    p#run();
 
829
    last_response_header := Some(call#response_header);
 
830
    match is_error_response path call with
 
831
      | None ->
 
832
          ()
 
833
      | Some _ ->
 
834
          handle_error path call
 
835
 
 
836
  method copy _ path1 path2 = assert false (* TODO *)
 
837
 
 
838
  method rename _ path1 path2 =
 
839
    raise(Unix.Unix_error(Unix.ENOSYS, "Http_fs.rename", path1))
 
840
 
 
841
  method readlink _ path =
 
842
    raise(Unix.Unix_error(Unix.ENOSYS, "Http_fs.readlink", path))
 
843
 
 
844
  method symlink _ path1 path2 = 
 
845
    raise(Unix.Unix_error(Unix.ENOSYS, "Http_fs.symlink", path1))
 
846
 
 
847
  method mkdir _ path = 
 
848
    raise(Unix.Unix_error(Unix.ENOSYS, "Http_fs.mkdir", path))
 
849
 
 
850
  method rmdir _ path = 
 
851
    raise(Unix.Unix_error(Unix.ENOSYS, "Http_fs.rmdir", path))
 
852
 
 
853
end
 
854
 
 
855
  
 
856
let http_fs = new http_fs