http_request.ml

   1
   2 (*
   3   OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
   4
   5   Copyright (C) <2002> Stefano Zacchiroli <zack@cs.unibo.it>
   6
   7   This program is free software; you can redistribute it and/or modify
   8   it under the terms of the GNU General Public License as published by
   9   the Free Software Foundation; either version 2 of the License, or
  10   (at your option) any later version.
  11
  12   This program is distributed in the hope that it will be useful,
  13   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15   GNU General Public License for more details.
  16
  17   You should have received a copy of the GNU General Public License
  18   along with this program; if not, write to the Free Software
  19   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  20 *)
  21
  22 open Printf;;
  23
  24 open Http_common;;
  25 open Http_types;;
  26
  27 let debug_dump_request path params =
  28   debug_print ("request path = " ^ path);
  29   debug_print (
  30     sprintf"request params = %s"
  31       (String.concat ";"
  32         (List.map (fun (h,v) -> String.concat "=" [h;v]) params)))
  33
  34 exception Fallback;;  (* used internally by request class *)
  35
  36 class request ic =
  37   let (meth, uri, version) = Http_parser.parse_request_fst_line ic in
  38   let uri_str = Neturl.string_of_url uri in
  39   let path = Http_parser.parse_path uri in
  40   let query_get_params = Http_parser.parse_query_get_params uri in
  41   let headers = Http_parser.parse_headers ic in (* trailing \r\n consumed! *)
  42   let body =
  43     (* TODO fallback on Transfer-Encoding if Content-Length isn't defined *)
  44     if meth = `POST then
  45       Buffer.contents
  46         (try  (* read only Content-Length bytes *)
  47           let limit_raw =
  48             (try
  49               (snd (List.find
  50                 (fun (h,v) -> String.lowercase h = "content-length") headers))
  51             with Not_found -> raise Fallback)
  52           in
  53           let limit =
  54             (try  (* TODO supports only a maximum content-length of 1Gb *)
  55               int_of_string limit_raw
  56             with Failure "int_of_string" ->
  57               raise (Invalid_header ("Content-Length: " ^ limit_raw)))
  58           in
  59           Http_misc.buf_of_inchan ~limit ic
  60         with Fallback -> Http_misc.buf_of_inchan ic)  (* read until EOF *)
  61     else "" (* TODO empty body for methods other than POST, is what we want? *)
  62   in
  63     (* TODO brave assumption: when meth = `POST, Content-Type is
  64     application/x-www-form-urlencoded and is therefore one-liner parsed as a GET
  65     query *)
  66   let query_post_params =
  67     match meth with
  68     | `POST -> Http_parser.split_query_params body
  69     | _ -> []
  70   in
  71   let params = query_post_params @ query_get_params in (* prefers POST params *)
  72   let _ = debug_dump_request path params in
  73   let (clisockaddr, srvsockaddr) =
  74     (Http_misc.peername_of_in_channel ic, Http_misc.sockname_of_in_channel ic)
  75   in
  76
  77   object (self)
  78
  79     inherit
  80       Http_message.message ~body ~headers ~version ~clisockaddr ~srvsockaddr
  81
  82     val params_tbl =
  83       let tbl = Hashtbl.create (List.length params) in
  84       List.iter (fun (n,v) -> Hashtbl.add tbl n v) params;
  85       tbl
  86
  87     method meth = meth
  88     method uri = uri_str
  89     method path = path
  90     method param ?meth name =
  91       (match (meth: meth option) with
  92       | None ->
  93           (try
  94             Hashtbl.find params_tbl name
  95           with Not_found -> raise (Param_not_found name))
  96       | Some `GET -> List.assoc name query_get_params
  97       | Some `POST -> List.assoc name query_post_params)
  98     method paramAll ?meth name =
  99       (match (meth: meth option) with
 100       | None -> List.rev (Hashtbl.find_all params_tbl name)
 101       | Some `GET -> Http_misc.list_assoc_all name query_get_params
 102       | Some `POST -> Http_misc.list_assoc_all name query_post_params)
 103     method params = params
 104     method params_GET = query_get_params
 105     method params_POST = query_post_params
 106
 107     method private fstLineToString =
 108       sprintf "%s %s %s"
 109         (string_of_method self#meth) self#uri (string_of_version self#version)
 110
 111   end
 112
 113 (*    (* OLD IMPLEMENTATION *)
 114 class request
 115   ~body ~headers ~version ~meth ~uri
 116   ~clisockaddr ~srvsockaddr
 117   ~path ~params
 118   ()
 119   =
 120   object (self)
 121
 122     inherit
 123       Http_message.message ~body ~headers ~version ~clisockaddr ~srvsockaddr
 124
 125     val params_tbl =
 126       let tbl = Hashtbl.create (List.length params) in
 127       List.iter (fun (n,v) -> Hashtbl.add tbl n v) params;
 128       tbl
 129
 130     method meth = meth
 131     method uri = uri
 132     method path = path
 133     method param name =
 134       try
 135         Hashtbl.find params_tbl name
 136       with Not_found ->
 137         raise (Param_not_found name)
 138     method paramAll name = List.rev (Hashtbl.find_all params_tbl name)
 139     method params = params
 140
 141     method private fstLineToString =
 142       sprintf
 143         "%s %s %s"
 144         (string_of_method self#meth)
 145         self#uri
 146         (string_of_version self#version)
 147
 148   end
 149 *)
 150