X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Focaml-http%2Fhttp_request.ml;h=cd2dcd16563f8dfdd1139ba951e8720e54520dae;hb=4167cea65ca58897d1a3dbb81ff95de5074700cc;hp=91bc98a67ac5138fe8a001671037b0e8c9bb4449;hpb=6a8da4dd52033adfe80533f7467439aec1561147;p=helm.git diff --git a/helm/DEVEL/ocaml-http/http_request.ml b/helm/DEVEL/ocaml-http/http_request.ml index 91bc98a67..cd2dcd165 100644 --- a/helm/DEVEL/ocaml-http/http_request.ml +++ b/helm/DEVEL/ocaml-http/http_request.ml @@ -2,43 +2,144 @@ (* OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - Copyright (C) <2002> Stefano Zacchiroli + Copyright (C) <2002-2005> Stefano Zacchiroli This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. + it under the terms of the GNU Library General Public License as + published by the Free Software Foundation, version 2. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. + GNU Library General Public License for more details. - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + You should have received a copy of the GNU Library General Public + License along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 + USA *) +open Printf;; + open Http_common;; +open Http_types;; + +let debug_dump_request path params = + debug_print ("request path = " ^ path); + debug_print ( + sprintf"request params = %s" + (String.concat ";" + (List.map (fun (h,v) -> String.concat "=" [h;v]) params))) + +let auth_sep_RE = Pcre.regexp ":" +let basic_auth_RE = Pcre.regexp "^Basic\\s+" -exception Param_not_found of string +exception Fallback;; (* used internally by request class *) + +class request ic = + let (meth, uri, version) = Http_parser.parse_request_fst_line ic in + let uri_str = Neturl.string_of_url uri in + let path = Http_parser.parse_path uri in + let query_get_params = Http_parser.parse_query_get_params uri in + let (headers, body) = + (match version with + | None -> [], "" (* No version given, use request's 1st line only *) + | Some version -> (* Version specified, parse also headers and body *) + let headers = + List.map (* lowercase header names to ease lookups before having a + request object *) + (fun (h,v) -> (String.lowercase h, v)) + (Http_parser.parse_headers ic) (* trailing \r\n consumed! *) + in + let body = + (* TODO fallback on size defined in Transfer-Encoding if + Content-Length isn't defined *) + if meth = `POST then + Buffer.contents + (try (* read only Content-Length bytes *) + let limit_raw = + (try + List.assoc "content-length" headers + with Not_found -> raise Fallback) + in + let limit = + (try (* TODO supports only a maximum content-length of 1Gb *) + int_of_string limit_raw + with Failure "int_of_string" -> + raise (Invalid_header ("content-length: " ^ limit_raw))) + in + Http_misc.buf_of_inchan ~limit ic + with Fallback -> Http_misc.buf_of_inchan ic) (* read until EOF *) + else (* TODO empty body for methods other than POST, is ok? *) + "" + in + (headers, body)) + in + let query_post_params = + match meth with + | `POST -> + let ct = try List.assoc "content-type" headers with Not_found -> "" in + if ct = "application/x-www-form-urlencoded" then + Http_parser.split_query_params body + else [] + | _ -> [] + in + let params = query_post_params @ query_get_params in (* prefers POST params *) + let _ = debug_dump_request path params in + let (clisockaddr, srvsockaddr) = + (Http_misc.peername_of_in_channel ic, Http_misc.sockname_of_in_channel ic) + in -class request ~path ~params = object (self) + + inherit + Http_message.message ~body ~headers ~version ~clisockaddr ~srvsockaddr + val params_tbl = let tbl = Hashtbl.create (List.length params) in List.iter (fun (n,v) -> Hashtbl.add tbl n v) params; tbl - val uri = - path ^ "?" ^ - (String.concat "&" (List.map (fun (n, v) -> n ^ "=" ^ v) params)) - method uri = uri + + method meth = meth + method uri = uri_str method path = path - method param name = + method param ?(meth: meth option) ?(default: string option) name = try - Hashtbl.find params_tbl name + (match meth with + | None -> Hashtbl.find params_tbl name + | Some `GET -> List.assoc name query_get_params + | Some `POST -> List.assoc name query_post_params) with Not_found -> - raise (Param_not_found name) + (match default with + | None -> raise (Param_not_found name) + | Some value -> value) + method paramAll ?meth name = + (match (meth: meth option) with + | None -> List.rev (Hashtbl.find_all params_tbl name) + | Some `GET -> Http_misc.list_assoc_all name query_get_params + | Some `POST -> Http_misc.list_assoc_all name query_post_params) method params = params + method params_GET = query_get_params + method params_POST = query_post_params + + method private fstLineToString = + let method_string = string_of_method self#meth in + match self#version with + | Some version -> + sprintf "%s %s %s" method_string self#uri (string_of_version version) + | None -> sprintf "%s %s" method_string self#uri + + method authorization: auth_info option = + try + let credentials = + Netencoding.Base64.decode + (Pcre.replace ~rex:basic_auth_RE (self#header "authorization")) + in + debug_print ("HTTP Basic auth credentials: " ^ credentials); + (match Pcre.split ~rex:auth_sep_RE credentials with + | [username; password] -> Some (`Basic (username, password)) + | l -> raise Exit) + with Header_not_found _ | Invalid_argument _ | Exit -> None + end