helm/DEVEL/pxp/netstring/cgi.ml

   1 (* $Id$
   2  * ----------------------------------------------------------------------
   3  *
   4  *)
   5
   6 exception Resources_exceeded
   7
   8 type argument_processing = Memory | File | Automatic;;
   9
  10 type argument =
  11     { mutable arg_name : string;
  12       mutable arg_processing : argument_processing;
  13       mutable arg_buf_value : Buffer.t;
  14       mutable arg_mem_value : string option;
  15               (* Here, the value is stored if it must be kept in memory *)
  16       mutable arg_disk_value : string Weak.t;
  17               (* This component is used iff arg_mem_value = None. The
  18                * weak array has a length of 1, and the single element stores
  19                * the value (if any).
  20                *)
  21       mutable arg_file : string option;
  22               (* The filename of the temporary file storing the value *)
  23       mutable arg_fd : out_channel option;
  24               (* The file descriptor of the temp file (if open) *)
  25       mutable arg_mimetype : string;
  26       mutable arg_filename : string option;
  27       mutable arg_header : (string * string) list;
  28               (* For the last three components, see the description of the
  29                * corresponding functions in the mli file.
  30                *)
  31     }
  32 ;;
  33
  34 type workaround =
  35     Work_around_MSIE_Content_type_bug
  36   | Work_around_backslash_bug
  37 ;;
  38
  39 type config =
  40     { maximum_content_length : int;
  41       how_to_process_arguments : argument -> argument_processing;
  42       tmp_directory : string;
  43       tmp_prefix : string;
  44       workarounds : workaround list;
  45     }
  46 ;;
  47
  48
  49 let print_argument arg =
  50   Format.printf
  51     "<CGIARG name=%s filename=%s mimetype=%s store=%s>"
  52     arg.arg_name
  53     (match arg.arg_filename with None -> "*" | Some n -> n)
  54     arg.arg_mimetype
  55     (match arg.arg_file with None -> "Memory" | Some n -> n)
  56 ;;
  57
  58
  59 let encode = Netencoding.Url.encode ;;
  60 let decode = Netencoding.Url.decode ;;
  61
  62
  63
  64 let url_split_re =
  65   Str.regexp "[&=]";;
  66
  67
  68 let mk_url_encoded_parameters nv_pairs =
  69   String.concat "&"
  70     (List.map
  71        (fun (name,value) ->
  72           let name_encoded = Netencoding.Url.encode name in
  73           let value_encoded = Netencoding.Url.encode value in
  74           name_encoded ^ "=" ^ value_encoded
  75        )
  76        nv_pairs
  77     )
  78 ;;
  79
  80
  81 let dest_url_encoded_parameters parstr =
  82
  83   let rec parse_after_amp tl =
  84     match tl with
  85         Str.Text name :: Str.Delim "=" :: Str.Text value :: tl' ->
  86           (Netencoding.Url.decode name,
  87            Netencoding.Url.decode value) :: parse_next tl'
  88       | Str.Text name :: Str.Delim "=" :: Str.Delim "&" :: tl' ->
  89           (Netencoding.Url.decode name, "") :: parse_after_amp tl'
  90       | Str.Text name :: Str.Delim "=" :: [] ->
  91           [Netencoding.Url.decode name, ""]
  92       | _ ->
  93           failwith "Cgi.dest_url_encoded_parameters"
  94   and parse_next tl =
  95     match tl with
  96         [] -> []
  97       | Str.Delim "&" :: tl' ->
  98           parse_after_amp tl'
  99       | _ ->
 100           failwith "Cgi.dest_url_encoded_parameters"
 101   in
 102   let toklist = Str.full_split url_split_re parstr in
 103   match toklist with
 104       [] -> []
 105     | _ -> parse_after_amp toklist
 106 ;;
 107
 108
 109 let mk_form_encoded_parameters ntv_triples =
 110   failwith "Cgi.mk_form_encoded_parameters: not implemented";;
 111
 112
 113 let dest_parameter_header header options =
 114   let get_name s =
 115     (* s is: form-data; ... name="fieldname" ...
 116      * Extract "fieldname"
 117      *)
 118     try
 119       let tok, params = Mimestring.scan_value_with_parameters s options in
 120       List.assoc "name" params
 121     with
 122         Not_found ->
 123           failwith "Cgi.dest_form_encoded_parameters"
 124       | Failure "Mimestring.scan_value_with_parameters" ->
 125           failwith "Cgi.dest_form_encoded_parameters"
 126   in
 127
 128   let get_filename s =
 129     (* s is: form-data; ... filename="fieldname" ...
 130      * Extract "fieldname"
 131      *)
 132     try
 133       let tok, params = Mimestring.scan_value_with_parameters s options in
 134       Some(List.assoc "filename" params)
 135     with
 136         Not_found ->
 137           None
 138       | Failure "Mimestring.scan_value_with_parameters" ->
 139           failwith "Cgi.dest_form_encoded_parameters"
 140   in
 141
 142   let mime_type =
 143     try List.assoc "content-type" header
 144     with Not_found -> "text/plain" in     (* the default *)
 145
 146   let content_disposition =
 147     try List.assoc "content-disposition" header
 148     with
 149         Not_found ->
 150           failwith "Cgi.dest_form_encoded_parameters: no content-disposition"
 151   in
 152
 153   let name = get_name content_disposition in
 154   let filename = get_filename content_disposition in
 155
 156   name, mime_type, filename
 157 ;;
 158
 159
 160 let dest_form_encoded_parameters parstr ~boundary config =
 161   let options =
 162     if List.mem Work_around_backslash_bug config.workarounds then
 163       [ Mimestring.No_backslash_escaping ]
 164     else
 165       []
 166   in
 167   let parts =
 168     Mimestring.scan_multipart_body_and_decode
 169       parstr 0 (String.length parstr) boundary in
 170   List.map
 171     (fun (params, value) ->
 172
 173       let name, mime_type, filename = dest_parameter_header params options in
 174       { arg_name = name;
 175         arg_processing = Memory;
 176         arg_buf_value = Buffer.create 1;
 177         arg_mem_value = Some value;
 178         arg_disk_value = Weak.create 1;
 179         arg_file = None;
 180         arg_fd = None;
 181         arg_mimetype = mime_type;
 182         arg_filename = filename;
 183         arg_header = params;
 184       }
 185
 186     )
 187     parts
 188 ;;
 189
 190
 191 let make_temporary_file config =
 192   (* Returns (filename, out_channel). *)
 193   let rec try_creation n =
 194     try
 195       let fn =
 196         Filename.concat
 197           config.tmp_directory
 198           (config.tmp_prefix ^ "-" ^ (string_of_int n))
 199       in
 200       let fd =
 201         open_out_gen
 202           [ Open_wronly; Open_creat; Open_excl; Open_binary ]
 203           0o666
 204           fn
 205       in
 206       fn, fd
 207     with
 208         Sys_error m ->
 209           (* This does not look very intelligent, but it is the only chance
 210            * to limit the number of trials.
 211            *)
 212           if n > 1000 then
 213             failwith ("Cgi: Cannot create temporary file: " ^ m);
 214           try_creation (n+1)
 215   in
 216   try_creation 0
 217 ;;
 218
 219
 220 let dest_form_encoded_parameters_from_netstream s ~boundary config =
 221   let parts = ref [] in
 222   let options =
 223     if List.mem Work_around_backslash_bug config.workarounds then
 224       [ Mimestring.No_backslash_escaping ]
 225     else
 226       []
 227   in
 228
 229   let create header =
 230     (* CALLBACK for scan_multipart_body_from_netstream *)
 231     let name, mime_type, filename = dest_parameter_header header options in
 232     let p0 =
 233       { arg_name = name;
 234         arg_processing = Memory;
 235         arg_buf_value = Buffer.create 80;
 236         arg_mem_value = None;
 237         arg_disk_value = Weak.create 1;
 238         arg_file = None;
 239         arg_fd = None;
 240         arg_mimetype = mime_type;
 241         arg_filename = filename;
 242         arg_header = header;
 243       }
 244     in
 245     let pr = config.how_to_process_arguments p0 in
 246     let p = { p0 with arg_processing = pr } in
 247     if pr = File then begin
 248       let fn, fd = make_temporary_file config in
 249       p.arg_file <- Some fn;
 250       p.arg_fd   <- Some fd;
 251       p.arg_mem_value <- None;
 252     end;
 253     p
 254   in
 255
 256   let add p s k n =
 257     (* CALLBACK for scan_multipart_body_from_netstream *)
 258     if (p.arg_processing = Automatic) &&
 259        (Buffer.length (p.arg_buf_value) >= Netstream.block_size s) then begin
 260          (* This is a LARGE argument *)
 261          p.arg_processing <- File;
 262          let fn, fd = make_temporary_file config in
 263          p.arg_file <- Some fn;
 264          p.arg_fd   <- Some fd;
 265          p.arg_mem_value <- None;
 266          output_string fd (Buffer.contents p.arg_buf_value);
 267          p.arg_buf_value <- Buffer.create 1;
 268        end;
 269
 270     match p.arg_processing with
 271         (Memory|Automatic) ->
 272           Buffer.add_substring
 273             p.arg_buf_value
 274             (Netbuffer.unsafe_buffer (Netstream.window s))
 275             k
 276             n
 277       | File ->
 278           let fd = match p.arg_fd with Some fd -> fd | None -> assert false in
 279           output
 280             fd
 281             (Netbuffer.unsafe_buffer (Netstream.window s))
 282             k
 283             n;
 284   in
 285
 286   let stop p =
 287     (* CALLBACK for scan_multipart_body_from_netstream *)
 288     begin match p.arg_processing with
 289         (Memory|Automatic) ->
 290           p.arg_mem_value <- Some (Buffer.contents p.arg_buf_value);
 291           p.arg_buf_value <- Buffer.create 1;
 292       | File ->
 293           let fd = match p.arg_fd with Some fd -> fd | None -> assert false in
 294           close_out fd;
 295           p.arg_mem_value <- None
 296     end;
 297     parts := p :: !parts
 298   in
 299
 300   Mimestring.scan_multipart_body_from_netstream
 301     s
 302     boundary
 303     create
 304     add
 305     stop;
 306
 307   List.rev !parts
 308 ;;
 309
 310
 311 let getenv name =
 312   try Sys.getenv name with Not_found -> "";;
 313
 314 (* getenv:
 315  * We use this getenv instead of Sys.getenv. The CGI specification does not
 316  * say anything about what should happen if a certain environment variable
 317  * is not set.
 318  * Some servers initialize the environment variable to the empty string if
 319  * it is not applicable, some servers do not set the variable at all. Because
 320  * of this, unset variables are always reported as empty variables.
 321  *
 322  * This is especially a problem with QUERY_STRING.
 323  *)
 324
 325 let mk_simple_arg ~name v =
 326   { arg_name = name;
 327     arg_processing = Memory;
 328     arg_buf_value = Buffer.create 1;
 329     arg_mem_value = Some v;
 330     arg_disk_value = Weak.create 0;
 331     arg_file = None;
 332     arg_fd = None;
 333     arg_mimetype = "text/plain";
 334     arg_filename = None;
 335     arg_header = [];
 336   }
 337 ;;
 338
 339 let mk_memory_arg ~name ?(mime = "text/plain") ?filename ?(header = []) v =
 340   { arg_name = name;
 341     arg_processing = Memory;
 342     arg_buf_value = Buffer.create 1;
 343     arg_mem_value = Some v;
 344     arg_disk_value = Weak.create 0;
 345     arg_file = None;
 346     arg_fd = None;
 347     arg_mimetype = mime;
 348     arg_filename = filename;
 349     arg_header = header;
 350   }
 351 ;;
 352
 353 let mk_file_arg
 354   ~name ?(mime = "text/plain") ?filename ?(header = []) v_filename =
 355   let v_abs_filename =
 356     if Filename.is_relative v_filename then
 357       Filename.concat (Sys.getcwd()) v_filename
 358     else
 359       v_filename
 360   in
 361   { arg_name = name;
 362     arg_processing = File;
 363     arg_buf_value = Buffer.create 1;
 364     arg_mem_value = None;
 365     arg_disk_value = Weak.create 0;
 366     arg_file = Some v_abs_filename;
 367     arg_fd = None;
 368     arg_mimetype = mime;
 369     arg_filename = filename;
 370     arg_header = header;
 371   }
 372 ;;
 373
 374
 375 let get_content_type config =
 376   (* Get the environment variable CONTENT_TYPE; if necessary apply
 377    * workarounds for browser bugs.
 378    *)
 379   let content_type = getenv "CONTENT_TYPE" in
 380   let user_agent = getenv "HTTP_USER_AGENT" in
 381   let eff_content_type =
 382     if Str.string_match (Str.regexp ".*MSIE") user_agent 0 &&
 383        List.mem Work_around_MSIE_Content_type_bug config.workarounds
 384     then begin
 385       (* Microsoft Internet Explorer: When used with SSL connections,
 386        * this browser sometimes produces CONTENT_TYPEs like
 387        * "multipart/form-data; boundary=..., multipart/form-data; boundary=..."
 388        * Workaround: Throw away everything after ", ".
 389        *)
 390       if Str.string_match (Str.regexp "\\([^,]*boundary[^,]*\\), .*boundary")
 391                           content_type 0
 392       then
 393         Str.matched_group 1 content_type
 394       else
 395         content_type
 396     end
 397     else
 398       content_type
 399   in
 400   eff_content_type
 401 ;;
 402
 403
 404 let really_parse_args config =
 405   let make_simple_arg (n,v) = mk_simple_arg n v in
 406
 407   match getenv "REQUEST_METHOD" with
 408       ("GET"|"HEAD") ->
 409         List.map
 410           make_simple_arg
 411           (dest_url_encoded_parameters(getenv "QUERY_STRING"))
 412
 413     | "POST" ->
 414         let n =
 415           try
 416             int_of_string (getenv "CONTENT_LENGTH")
 417           with
 418               _ -> failwith "Cgi.parse_arguments"
 419         in
 420         if n > config.maximum_content_length then
 421           raise Resources_exceeded;
 422         begin
 423           let mime_type, params =
 424             Mimestring.scan_mime_type(get_content_type config) [] in
 425           match mime_type with
 426               "application/x-www-form-urlencoded" ->
 427                 let buf = String.create n in
 428                 really_input stdin buf 0 n;
 429                 List.map
 430                   make_simple_arg
 431                   (dest_url_encoded_parameters buf)
 432             | "multipart/form-data" ->
 433                 let boundary =
 434                   try
 435                     List.assoc "boundary" params
 436                   with
 437                       Not_found ->
 438                         failwith "Cgi.parse_arguments"
 439                 in
 440                 (* -------------------------------------------------- DEBUG
 441                    let f = open_out "/tmp/cgiout" in
 442                    output_string f buf;
 443                    close_out f;
 444                  * --------------------------------------------------
 445                  *)
 446                 dest_form_encoded_parameters_from_netstream
 447                   (Netstream.create_from_channel stdin (Some n) 4096)
 448                   boundary
 449                   config
 450             | _ ->
 451                 failwith ("Cgi.parse_arguments: unknown content-type " ^ mime_type)
 452         end
 453     | _ ->
 454         failwith "Cgi.parse_arguments: unknown method"
 455
 456 let parsed = ref None;;    (* protected by lock/unlock *)
 457
 458 let lock   = ref (fun () -> ());;
 459 let unlock = ref (fun () -> ());;
 460
 461 let init_mt new_lock new_unlock =
 462   lock   := new_lock;
 463   unlock := new_unlock
 464 ;;
 465
 466 let protect f =
 467   !lock();
 468   try
 469     let r = f() in
 470     !unlock();
 471     r
 472   with
 473       x ->
 474         !unlock();
 475         raise x
 476 ;;
 477
 478 let parse_arguments config =
 479   protect
 480     (fun () ->
 481        match !parsed with
 482            Some _ -> ()
 483          | None ->
 484              parsed := Some (List.map
 485                                (fun arg -> arg.arg_name, arg)
 486                                (really_parse_args config))
 487     )
 488 ;;
 489
 490 let arguments () =
 491   protect
 492     (fun () ->
 493        match !parsed with
 494            Some plist -> plist
 495          | None ->
 496              failwith "Cgi.arguments"
 497     )
 498 ;;
 499
 500 let set_arguments arglist =
 501   protect
 502     (fun () ->
 503        parsed := Some (List.map
 504                          (fun arg -> arg.arg_name, arg)
 505                          arglist)
 506     )
 507 ;;
 508
 509 let default_config =
 510   { maximum_content_length = max_int;
 511     how_to_process_arguments = (fun _ -> Memory);
 512     tmp_directory = "/var/tmp";
 513     tmp_prefix = "cgi-";
 514     workarounds = [ Work_around_MSIE_Content_type_bug;
 515                     Work_around_backslash_bug;
 516                   ]
 517   }
 518 ;;
 519
 520 let arg_value arg =
 521   match arg.arg_mem_value with
 522       None ->
 523         begin
 524           match Weak.get arg.arg_disk_value 0 with
 525               None ->
 526                 begin
 527                   match arg.arg_file with
 528                       None ->
 529                         failwith "Cgi.arg_value: no value present"
 530                     | Some filename ->
 531                         let fd = open_in_bin filename in
 532                         try
 533                           let len = in_channel_length fd in
 534                           let s = String.create len in
 535                           really_input fd s 0 len;
 536                           Weak.set arg.arg_disk_value 0 (Some s);
 537                           close_in fd;
 538                           s
 539                         with
 540                             any -> close_in fd; raise any
 541                 end
 542             | Some v -> v
 543         end
 544     | Some s ->
 545         s
 546 ;;
 547
 548 let arg_name     arg = arg.arg_name;;
 549 let arg_file     arg = arg.arg_file;;
 550 let arg_mimetype arg = arg.arg_mimetype;;
 551 let arg_filename arg = arg.arg_filename;;
 552 let arg_header   arg = arg.arg_header;;
 553
 554 let cleanup () =
 555   protect
 556     (fun () ->
 557        match !parsed with
 558            None -> ()
 559          | Some plist ->
 560              List.iter
 561                (fun (name, arg) ->
 562                   match arg.arg_file with
 563                       None -> ()
 564                     | Some filename ->
 565                         (* We do not complain if the file does not exist anymore. *)
 566                         if Sys.file_exists filename then
 567                           Sys.remove filename;
 568                         arg.arg_file <- None
 569                )
 570                plist
 571     )
 572 ;;
 573
 574 let argument name = List.assoc name (arguments());;
 575 let argument_value name = arg_value (argument name);;
 576
 577 module Operators = struct
 578   let ( !% ) = argument
 579   let ( !$ ) = argument_value
 580 end;;
 581
 582
 583 let parse_args() =
 584   parse_arguments default_config;
 585   List.map
 586     (fun (name, arg) -> name, arg_value arg)
 587     (arguments())
 588 ;;
 589
 590 let parse_args_with_mimetypes() =
 591   parse_arguments default_config;
 592   List.map
 593     (fun (name, arg) -> name, arg_mimetype arg, arg_value arg)
 594     (arguments())
 595 ;;
 596
 597 let header s =
 598   let t =
 599     match s with
 600         "" -> "text/html"
 601       | _  -> s
 602   in
 603   print_string ("Content-type: " ^ t ^ "\n\n");
 604   flush stdout
 605 ;;
 606
 607
 608 let this_url() =
 609   "http://" ^ (getenv "SERVER_NAME") ^ (getenv "SCRIPT_NAME")
 610 ;;
 611
 612
 613 (* ======================================================================
 614  * History:
 615  *
 616  * $Log$
 617  * Revision 1.1  2000/11/17 09:57:27  lpadovan
 618  * Initial revision
 619  *
 620  * Revision 1.8  2000/06/25 22:34:43  gerd
 621  *      Added labels to arguments.
 622  *
 623  * Revision 1.7  2000/06/25 21:40:36  gerd
 624  *      Added printer.
 625  *
 626  * Revision 1.6  2000/06/25 21:15:48  gerd
 627  *      Checked thread-safety.
 628  *
 629  * Revision 1.5  2000/05/16 22:29:36  gerd
 630  *      Added support for two common file upload bugs.
 631  *
 632  * Revision 1.4  2000/04/15 16:47:27  gerd
 633  *      Last minor changes before releasing 0.6.
 634  *
 635  * Revision 1.3  2000/04/15 13:09:01  gerd
 636  *      Implemented uploads to temporary files.
 637  *
 638  * Revision 1.2  2000/03/02 01:15:30  gerd
 639  *      Updated.
 640  *
 641  * Revision 1.1  2000/02/25 15:21:12  gerd
 642  *      Initial revision.
 643  *
 644  *
 645  *)