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