helm/DEVEL/ocaml-http/http_request.ml

   1
   2 (*
   3   OCaml HTTP - do it yourself (fully OCaml) HTTP daemon
   4
   5   Copyright (C) <2002-2004> 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 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 name =
 107       (match (meth: meth option) with
 108       | None ->
 109           (try
 110             Hashtbl.find params_tbl name
 111           with Not_found -> raise (Param_not_found name))
 112       | Some `GET -> List.assoc name query_get_params
 113       | Some `POST -> List.assoc name query_post_params)
 114     method paramAll ?meth name =
 115       (match (meth: meth option) with
 116       | None -> List.rev (Hashtbl.find_all params_tbl name)
 117       | Some `GET -> Http_misc.list_assoc_all name query_get_params
 118       | Some `POST -> Http_misc.list_assoc_all name query_post_params)
 119     method params = params
 120     method params_GET = query_get_params
 121     method params_POST = query_post_params
 122
 123     method private fstLineToString =
 124       let method_string = string_of_method self#meth in
 125       match self#version with
 126       | Some version ->
 127           sprintf "%s %s %s" method_string self#uri (string_of_version version)
 128       | None -> sprintf "%s %s" method_string self#uri
 129
 130     method authorization: auth_info option =
 131       try
 132         let credentials =
 133           Netencoding.Base64.decode
 134             (Pcre.replace ~rex:basic_auth_RE (self#header "authorization"))
 135         in
 136         debug_print ("HTTP Basic auth credentials: " ^ credentials);
 137         (match Pcre.split ~rex:auth_sep_RE credentials with
 138         | [username; password] -> Some (`Basic (username, password))
 139         | l -> raise Exit)
 140       with Header_not_found _ | Invalid_argument _ | Exit -> None
 141
 142   end
 143