]> matita.cs.unibo.it Git - helm.git/blob - http_request.ml
e3bc95bc1f5666d060802723448bd5e178563de6
[helm.git] / 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