]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/ocaml-http/http_request.ml
use ledit for debugging
[helm.git] / helm / DEVEL / ocaml-http / 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, body) =
42     (match version with
43     | None -> [], ""  (* No version given, use request's 1st line only *)
44     | Some version -> (* Version specified, parse also headers and body *)
45         let headers =
46           List.map  (* lowercase header names to ease lookups before having a
47                     request object *)
48             (fun (h,v) -> (String.lowercase h, v))
49             (Http_parser.parse_headers ic) (* trailing \r\n consumed! *)
50         in
51         let body =
52             (* TODO fallback on size defined in Transfer-Encoding if
53               Content-Length isn't defined *)
54           if meth = `POST then
55             Buffer.contents
56               (try  (* read only Content-Length bytes *)
57                 let limit_raw =
58                   (try
59                     List.assoc "content-length" headers
60                   with Not_found -> raise Fallback)
61                 in
62                 let limit =
63                   (try  (* TODO supports only a maximum content-length of 1Gb *)
64                     int_of_string limit_raw
65                   with Failure "int_of_string" ->
66                     raise (Invalid_header ("content-length: " ^ limit_raw)))
67                 in
68                 Http_misc.buf_of_inchan ~limit ic
69               with Fallback -> Http_misc.buf_of_inchan ic)  (* read until EOF *)
70           else  (* TODO empty body for methods other than POST, is ok? *)
71             ""
72         in
73         (headers, body))
74   in
75   let query_post_params =
76     match meth with
77     | `POST ->
78         let ct = try List.assoc "content-type" headers with Not_found -> "" in
79         if ct = "application/x-www-form-urlencoded" then
80           Http_parser.split_query_params body
81         else []
82     | _ -> []
83   in
84   let params = query_post_params @ query_get_params in (* prefers POST params *)
85   let _ = debug_dump_request path params in
86   let (clisockaddr, srvsockaddr) =
87     (Http_misc.peername_of_in_channel ic, Http_misc.sockname_of_in_channel ic)
88   in
89
90   object (self)
91
92     inherit
93       Http_message.message ~body ~headers ~version ~clisockaddr ~srvsockaddr
94
95     val params_tbl =
96       let tbl = Hashtbl.create (List.length params) in
97       List.iter (fun (n,v) -> Hashtbl.add tbl n v) params;
98       tbl
99
100     method meth = meth
101     method uri = uri_str
102     method path = path
103     method param ?meth name =
104       (match (meth: meth option) with
105       | None ->
106           (try
107             Hashtbl.find params_tbl name
108           with Not_found -> raise (Param_not_found name))
109       | Some `GET -> List.assoc name query_get_params
110       | Some `POST -> List.assoc name query_post_params)
111     method paramAll ?meth name =
112       (match (meth: meth option) with
113       | None -> List.rev (Hashtbl.find_all params_tbl name)
114       | Some `GET -> Http_misc.list_assoc_all name query_get_params
115       | Some `POST -> Http_misc.list_assoc_all name query_post_params)
116     method params = params
117     method params_GET = query_get_params
118     method params_POST = query_post_params
119
120     method private fstLineToString =
121       let method_string = string_of_method self#meth in
122       match self#version with
123       | Some version ->
124           sprintf "%s %s %s" method_string self#uri (string_of_version version)
125       | None -> sprintf "%s %s" method_string self#uri
126
127   end
128