Skip to content
This repository
tag: v988
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 168 lines (149 sloc) 5.308 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA 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 Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
open Printf
open Option
open Rp_typ
open Rp_hdr
open Requestdef
open RequestType

module S = String
module L = List

(*let req =
"GET /_internal_/code/all.js HTTP/1.1\r\n\
If-Modified-Since: Thu, 18 Nov 2010 17:12:02 GMT\r\n\
User-Agent: Mozilla/5.0 (X11; U; Linux i686 (x86_64); fr; rv:1.9.2.12) Gecko/20101026 Firefox/3.6.12\r\n\
Connection: keep-alive\r\n\
Cookie: 8d53aab25d7975f78b310cee5b9a158b\r\n\
Accept-Language: fr,fr-fr;q=0.8,en-us;q=0.5,en;q=0.3\r\n\
NewCookie: 8d53aab25d7975f78b310cee5b9a158b\r\n\
Host: localhost:8080\r\n\
Referer: http://localhost:8080/\r\n\
Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7\r\n\
Accept: */*\r\n\r\n"*)

exception ParseFail of int

let ug = S.unsafe_get

let pos_crlf str len n =
  let rec pc0 pos =
    if pos >= len
    then len, len
    else
      let c1 = ug str pos in
      if c1 = '\r' || c1 = '\n'
      then
        if pos + 1 >= len
        then pos, pos+1
        else
          let c2 = ug str (pos+1) in
          if (c1 = '\r' && c2 = '\n') || (c1 = '\n' && c2 = '\r')
          then pos, pos+2
          else
            if (c1 = '\r' && c2 = '\r') || (c1 = '\n' && c2 = '\n')
            then pos, pos+1
            else pc0 (pos+1)
      else pc0 (pos+1) in
  pc0 n

let upto_crlf str len n =
  let pos, p2 = pos_crlf str len n in
  let l = pos - n in
  (p2,l,S.sub str n l)

let pos_HTTP str len n =
  (*printf "pos_HTTP: str=%s len=%d n=%d\n" str len n;*)
  let rec pH pos =
    if pos >= len - 4
    then raise (ParseFail pos)
    else
      if ug str pos = 'H' && ug str (pos+1) = 'T' && ug str (pos+2) = 'T' && ug str (pos+3) = 'P'
      then pos
      else pH (pos+1) in
  pH n

let skip_lws str len n =
  let rec sl pos =
    if pos >= len
    then len
    else
      if ug str pos = ' ' || ug str pos = '\t' || ug str pos = '\r' || ug str pos = '\n'
      then sl (pos+1)
      else pos in
  sl n

(* field value can span multiple lines with newline + space *)
let upto_header_crlf str len n =
  let pos = skip_lws str len n in
  let pos0 = pos in
  let pos_, pos = pos_crlf str len pos in
  let len0 = pos_ - pos0 in
  let str0 = S.sub str pos0 len0 in
  if pos >= len
  then (len,len0,str0)
  else if ug str pos <> ' ' && ug str pos <> '\t'
  then (pos,len0,str0)
  else
    let rec uhc str1 len1 pos =
      let pos = skip_lws str len pos in
      let pos0 = pos in
      let pos_, pos = pos_crlf str len pos in
      let l = pos_ - pos0 in
      let len1 = len1 + l + 1 in
      let str1 = (S.sub str pos0 l)::str1 in
      if pos >= len
      then (len,len1,S.concat " " (L.rev str1))
      else if ug str pos <> ' ' && ug str pos <> '\t'
      then (pos,len1,S.concat " " (L.rev str1))
      else uhc str1 len1 pos
    in
    uhc [str0] len0 pos

let get_rh hdr hdrlen nxt rh start rqst =
  (* header field with no colon is a bad request *)
  if ug hdr start <> ':' then raise (ParseFail nxt);
  (* any number of spaces between colon and field value *)
  let cpos = skip_lws hdr hdrlen (start + 1) in
  let v = S.sub hdr cpos (hdrlen-cpos) in
  (*let att = S.sub hdr 0 (cpos-2) in printf "Att: %s Val: %s\n" att v;*)
  (* FIXME why this try with block ??? *)
  try RequestHeader.add rqst (`string v) rh with _ -> raise (ParseFail nxt)

let rec get_hd rl req reqlen nxt rh =
  let nxt2,hdrlen,hdr = upto_header_crlf req reqlen nxt in
  (*printf "Hdr: %s len: %d\n" hdr hdrlen;*)
  if hdr = ""
  then nxt2,Complete {request_line=rl; request_header=rh; request_message_body=""; server_info=None}
  else
    (* Unknown fieldname must be skipped *)
    let rh = try hdr_call get_rh hdr hdrlen nxt2 rh with ParseFail_hdr _ -> rh in
    get_hd rl req reqlen nxt2 rh

let get_rl typ typlen nxt req reqlen start _method =
  (*printf "get_rl:\nlet typ=\"%s\";;\nlet typlen=%d;;\nlet nxt=%d;;\nlet start=%d;;\n" typ typlen nxt start;*)
  let start = start+1 in
  let hpos = pos_HTTP typ typlen start in
  let uri = S.sub typ start (hpos-(start+1)) in
  let vstart = hpos in
  let vlen = typlen-vstart in
  if vlen <> 8 then raise (ParseFail nxt);
  let ver = S.sub typ vstart vlen in
  (*printf "Type: %s\n" typ;*)
  get_hd { _method = _method; request_uri = uri ; http_version = ver } req reqlen nxt RequestHeader.empty

let parse_request req =
  let reqlen = S.length req in
  try
    (* Crlf before request are allowed... *)
    let rec loop pos =
      match upto_crlf req reqlen pos with
      | nxt,0,"" -> loop nxt
      | nxt,typlen,typ -> typ_call get_rl typ typlen nxt req reqlen
    in
    loop 0
  with
    ParseFail nxt -> nxt,Incomplete
  | ParseFail_typ nxt -> nxt,Incomplete
  | ParseFail_hdr nxt -> nxt,Incomplete
  | _ -> reqlen,Incomplete

(*let _ = parse_request req*)
Something went wrong with that request. Please try again.