http/framepp.ml

   1 (* Ocsigen
   2  * framepp.ml Copyright (C) 2005 Denis Berthod
   3  * Laboratoire PPS - CNRS Université Paris Diderot
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU Lesser General Public License as published by
   7  * the Free Software Foundation, with linking exception;
   8  * either version 2.1 of the License, or (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU Lesser General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU Lesser General Public License
  16  * along with this program; if not, write to the Free Software
  17  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  18  *)
  19
  20 (** pretty printer for http frames*)
  21 open Ocsigen_http_frame
  22
  23 module H = Http_header
  24
  25 (** converts the method into a string*)
  26 let string_of_method =
  27   function
  28     | H.GET -> "GET"
  29     | H.POST -> "POST"
  30     | H.HEAD -> "HEAD"
  31     | H.PUT -> "PUT"
  32     | H.DELETE -> "DELETE"
  33     | H.TRACE -> "TRACE"
  34     | H.OPTIONS -> "OPTIONS"
  35     | H.CONNECT -> "CONNECT"
  36     | H.LINK -> "LINK"
  37     | H.UNLINK -> "UNLINK"
  38     | H.PATCH -> "PATCH"
  39
  40 (** converts a string to a method *)
  41 let method_of_string =
  42   function
  43     | "GET" -> H.GET
  44     | "POST" -> H.POST
  45     | "HEAD" -> H.HEAD
  46     | "PUT" -> H.PUT
  47     | "DELETE" -> H.DELETE
  48     | "TRACE" -> H.TRACE
  49     | "OPTIONS" -> H.OPTIONS
  50     | "CONNECT" -> H.CONNECT
  51     | "LINK" -> H.LINK
  52     | "UNLINK" -> H.UNLINK
  53     | "PATCH" -> H.PATCH
  54     | _ -> failwith "method_of_string"
  55
  56 (** converts the protocol into a string *)
  57 let string_of_proto = function
  58   | H.HTTP10 -> "HTTP/1.0"
  59   | H.HTTP11 -> "HTTP/1.1"
  60
  61 (** converts a string to a protocol *)
  62 let proto_of_string = function
  63   | "HTTP/1.0" -> H.HTTP10
  64   | "HTTP/1.1" -> H.HTTP11
  65   | _ -> failwith "proto_of_string"
  66
  67 (** Write the first line of an HTTP frame to a string buffer *)
  68 let fst_line buf header =
  69   match header.H.mode with
  70   | H.Nofirstline -> ()
  71   | H.Answer code ->
  72       Printf.bprintf buf "%s %i %s\r\n" (string_of_proto header.H.proto)
  73         code (Http_error.expl_of_code code)
  74   | H.Query (meth, url) ->
  75       Printf.bprintf buf "%s %s %s\r\n"
  76         (string_of_method meth) url (string_of_proto header.H.proto)
  77
  78
  79 (** Prints the content of a header. To prevent http header injection,
  80     we insert spaces (' ') after CRLF, in case the user has not done this
  81     himself. Also, if we find single CR or LF, we replace them by spaces .
  82     (This is correct according to the RFC, as the headers content should not
  83     contain single CR or LF anyway) *)
  84 let print_header_content buf content =
  85   let s = String.length content in
  86   let rec aux prev i =
  87     if i = s then
  88       (if prev < s then
  89          Buffer.add_substring buf content prev (s-prev))
  90     else
  91       let add_prev () = Buffer.add_substring buf content prev (i-prev) in
  92       match content.[i] with
  93         | '\n' | '\r' as c ->
  94             let i' = i+1 in
  95             let escape_c () =
  96               add_prev ();
  97               Buffer.add_char buf c;
  98               Buffer.add_char buf ' ';
  99               aux i' i'
 100             in
 101             if i' < s then
 102               (match content.[i'] with
 103                  | '\n' | '\r' as c' when c <> c' ->
 104                      add_prev ();
 105                      Buffer.add_char buf c; Buffer.add_char buf c';
 106                      Buffer.add_char buf ' ';
 107                      aux (i+2) (i+2)
 108
 109                  | _ -> escape_c ()
 110               ) else
 111                 escape_c ()
 112
 113         | _ ->
 114             aux prev (i+1)
 115   in
 116   aux 0 0
 117
 118 (* Debug *)
 119 let test s =
 120   let b = Buffer.create 0 in print_header_content b s; Buffer.contents b
 121
 122
 123 (** Write the header lines to a string buffer *)
 124 let headers buf header =
 125   Http_headers.iter
 126     (fun name value ->
 127        Printf.bprintf buf "%s: %a\r\n"
 128          (Http_headers.name_to_string name) print_header_content value)
 129     header.H.headers
 130
 131 (** Convert a HTTP header into a string *)
 132 let string_of_header hds =
 133   let buf = Buffer.create 200 in
 134   fst_line buf hds;
 135   headers buf hds;
 136   Printf.bprintf buf "\r\n%!";
 137   Buffer.contents buf