helm/DEVEL/ocaml-http/http_parser.ml

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