helm/DEVEL/ocaml-http/http_parser.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 open Http_constants;;
  27
  28 let (bindings_sep, binding_sep, pieces_sep, header_sep) =
  29   (Pcre.regexp "&", Pcre.regexp "=", Pcre.regexp " ", Pcre.regexp ":")
  30 let header_RE = Pcre.regexp "([^:]*):(.*)"
  31
  32 let url_decode url = Netencoding.Url.decode ~plus:true url
  33
  34 let split_query_params query =
  35   let bindings = Pcre.split ~rex:bindings_sep query in
  36   match bindings with
  37   | [] -> raise (Malformed_query query)
  38   | bindings ->
  39       List.map
  40         (fun binding ->
  41           match Pcre.split ~rex:binding_sep binding with
  42           | [ ""; b ] -> (* '=b' *)
  43               raise (Malformed_query_part (binding, query))
  44           | [ a; b ]  -> (* 'a=b' *) (url_decode a, url_decode b)
  45           | [ a ]     -> (* 'a=' || 'a' *) (url_decode a, "")
  46           | _ -> raise (Malformed_query_part (binding, query)))
  47         bindings
  48
  49   (** internal, used by generic_input_line *)
  50 exception Line_completed;;
  51
  52   (** given an input channel and a separator
  53   @return a line read from it (like Pervasives.input_line)
  54   line is returned only after reading a separator string; separator string isn't
  55   included in the returned value
  56   TODO what about efficiency?, input is performed char-by-char
  57   *)
  58 let generic_input_line ~sep ~ic =
  59   let sep_len = String.length sep in
  60   if sep_len < 1 then
  61     failwith ("Separator '" ^ sep ^ "' is too short!")
  62   else  (* valid separator *)
  63     let line = ref "" in
  64     let sep_pointer = ref 0 in
  65     try
  66       while true do
  67         if !sep_pointer >= String.length sep then (* line completed *)
  68           raise Line_completed
  69         else begin (* incomplete line: need to read more *)
  70           let ch = input_char ic in
  71           if ch = String.get sep !sep_pointer then  (* next piece of sep *)
  72             incr sep_pointer
  73           else begin  (* useful char *)
  74             for i = 0 to !sep_pointer - 1 do
  75               line := !line ^ (String.make 1 (String.get sep i))
  76             done;
  77             sep_pointer := 0;
  78             line := !line ^ (String.make 1 ch)
  79           end
  80         end
  81       done;
  82       assert false  (* unreacheable statement *)
  83     with Line_completed -> !line
  84
  85 let patch_empty_path = function "" -> "/" | s -> s
  86 let debug_dump_request path params =
  87   debug_print
  88     (sprintf
  89       "recevied request; path: %s; params: %s"
  90       path
  91       (String.concat ", " (List.map (fun (n, v) -> n ^ "=" ^ v) params)))
  92
  93 let parse_request_fst_line ic =
  94   let request_line = generic_input_line ~sep:crlf ~ic in
  95   debug_print (sprintf "HTTP request line (not yet parsed): %s" request_line);
  96   try
  97     (match Pcre.split ~rex:pieces_sep request_line with
  98     | [ meth_raw; uri_raw ] ->  (* ancient HTTP request line *)
  99         (method_of_string meth_raw,                 (* method *)
 100         Http_parser_sanity.url_of_string uri_raw,   (* uri *)
 101         None)                                       (* no version given *)
 102     | [ meth_raw; uri_raw; http_version_raw ] ->  (* HTTP 1.{0,1} *)
 103           (method_of_string meth_raw,                 (* method *)
 104           Http_parser_sanity.url_of_string uri_raw,   (* uri *)
 105           Some (version_of_string http_version_raw))  (* version *)
 106     | _ -> raise (Malformed_request request_line))
 107   with Malformed_URL url -> raise (Malformed_request_URI url)
 108
 109 let parse_response_fst_line ic =
 110   let response_line = generic_input_line ~sep:crlf ~ic in
 111   debug_print (sprintf "HTTP response line (not yet parsed): %s" response_line);
 112   try
 113     (match Pcre.split ~rex:pieces_sep response_line with
 114     | version_raw :: code_raw :: _ ->
 115         (version_of_string version_raw,             (* method *)
 116         status_of_code (int_of_string code_raw))    (* status *)
 117     | _ -> raise (Malformed_response response_line))
 118   with
 119   | Malformed_URL _ | Invalid_code _ | Failure "int_of_string" ->
 120       raise (Malformed_response response_line)
 121
 122 let parse_path uri = patch_empty_path (String.concat "/" (Neturl.url_path uri))
 123 let parse_query_get_params uri =
 124   try (* act on HTTP encoded URIs *)
 125     split_query_params (Neturl.url_query ~encoded:true uri)
 126   with Not_found -> []
 127
 128 let parse_headers ic =
 129   (* consume also trailing "^\r\n$" line *)
 130   let rec parse_headers' headers =
 131     match generic_input_line ~sep:crlf ~ic with
 132     | "" -> List.rev headers
 133     | line ->
 134         (let subs =
 135           try
 136             Pcre.extract ~rex:header_RE line
 137           with Not_found -> raise (Invalid_header line)
 138         in
 139         let header =
 140           try
 141             subs.(1)
 142           with Invalid_argument "Array.get" -> raise (Invalid_header line)
 143         in
 144         let value =
 145           try
 146             Http_parser_sanity.normalize_header_value subs.(2)
 147           with Invalid_argument "Array.get" -> ""
 148         in
 149         Http_parser_sanity.heal_header (header, value);
 150         parse_headers' ((header, value) :: headers))
 151   in
 152   parse_headers' []
 153
 154 let parse_request ic =
 155   let (meth, uri, version) = parse_request_fst_line ic in
 156   let path = parse_path uri in
 157   let query_get_params = parse_query_get_params uri in
 158   debug_dump_request path query_get_params;
 159   (path, query_get_params)
 160