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